perm filename STATS[S,AIL]14 blob
sn#056474 filedate 1973-08-02 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00044 PAGES VERSION 17-1(4)
RECORD PAGE DESCRIPTION
00001 00001
00005 00002 HISTORY
00014 00003 For-Loop, Case Statement Variables
00016 00004 Descriptions of For Loop Constructs, Bit Definitions
00021 00005 FOR, DO, WHILE, NEEDNEXT Generators
00025 00006
00030 00007
00033 00008 (continued), NEXT, DONE, CONTINUE
00038 00009
00042 00010
00046 00011
00053 00012
00055 00013 ENTLAB, TRA -- generators for label placement, Go To statements
00058 00014 TRAGO -- go-to-solver -- used also by RETURN code
00061 00015
00065 00016 CASSTR, CASEMT, CASEND, CASE1, ... -- Case Statement Generators
00068 00017
00072 00018
00075 00019 PROCEDURE Structure Descriptions, Data Declarations
00079 00020 PRDEC -- When Name is Seen
00087 00021 ENDPR -- when params have been seen
00096 00022 PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.
00100 00023
00102 00024
00110 00025
00114 00026 RESTOR, SAVIT,MKESMT,SETF -- Subroutines for Above
00120 00027 NOW THAT AC IS STATIC LINK, MIGHT AS WELL REMEMBER THAT FACT
00122 00028 TWPR1, TWPR2 -- Procedure Syntax Twiddlers
00123 00029 RDYCAL -- Prepare to Call Procedure
00128 00030 Describe CALARG
00130 00031 CALARG -- Pass a Parameter
00136 00032
00138 00033 MPPARM: BINDING ITEMVAR PARAMETER
00145 00034
00149 00035 ADRINS -- Subrt for Above -- Prepare an Address Constant (Semblk)
00153 00036
00156 00037
00159 00038 ISUCAL -- Call the Procedure, Mark Resultant Type, etc.
00168 00039
00171 00040 ARGFIX: HRL B,A FIXUP
00174 00041 RESULT -- Return (with or without value) from Procedure
00178 00042
00180 00043 DFVPV -- exec for default param values
00181 00044 CLNSET
00182 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000004 ⊗;
COMMENT ⊗
VERSION 17-1(4) 8-12-73 BY JRL BUG #NP# DRYROT IN MATCHING PROCEDURE WITHOUT ? PARAMETERS
VERSION 17-1(3) 7-30-73 BY RHT BUG #NI# FIXUP FOR CONTINUE IN A DO... UNTIL...
VERSION 17-1(2) 7-27-73 BY RHT BUG #NH# ADEPTH PROBLEM FOR DEFAULTS
VERSION 17-1(1) 7-27-73
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(63) 7-9-73 BY JRL REMOVE ALL REFERENCES TO PATSW
VERSION 16-2(62) 6-29-73 BY RHT BUG #MY# FIX A TYPO
VERSION 16-2(61) 6-28-73 BY RHT BUGS #MX# & #MY#
VERSION 16-2(60) 6-28-73
VERSION 16-2(59) 6-28-73
VERSION 16-2(58) 6-28-73
VERSION 16-2(57) 6-28-73 BY JRL BUG #MA# CONCHK SHOULD SAVE FF OVER ITS CALL
VERSION 16-2(56) 6-27-73 BY RHT BUG #MV# NEEDED AN ACCESS BEFORE A PUT
VERSION 16-2(55) 5-15-73 BY JRL BUG #MJ# FOR CODE REMOPING WRONG SEMBLK
VERSION 16-2(54) 5-12-73 BY RHT BUG #MH# DRYROT IN EPNT FROM LOOP CODE
VERSION 16-2(53) 4-25-73 BY JRL BUG #ME# DRYROT IN ENDPR FOR FORWARD MATCHING PROCEDURE
VERSION 16-2(52) 4-25-73
VERSION 16-2(51) 3-22-73 BY RHT ADD DEFAULT PARAM VALUES
VERSION 16-2(50) 3-20-73 BY RHT ADD CODE FOR DEFAULT PARAM VALUES (ISUCAL)
VERSION 16-2(49) 3-13-73 BY RHT BUG #LQ# FWRD PROC PD SHOULD BE USED WHEN DECLARE THE PROC
VERSION 16-2(48) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(47) 2-26-73
VERSION 16-2(46) 2-14-73 BY JRL BUG #LL# PROTECTION OF AC CONTAINING UNBOUND IN MATCH PROC
VERSION 16-2(45) 2-12-73 BY JRL RETURN VAL OF MP NOW SAVED IN XX AREA
VERSION 16-2(44) 2-12-73 BY JRL BUG #LK# GET RID OF DRYROT AT BPOP AT END OF MATCH PROC
VERSION 16-2(43) 2-9-73 BY JRL MAKE AN ITEM PROCEDURE
VERSION 16-2(42) 2-9-73 BY JRL BUG #LJ# LEAP SHOULD STACK EVERYTHING BEFORE PROCEDURE CALL
VERSION 16-2(41) 2-9-73
VERSION 16-2(40) 2-9-73
VERSION 16-2(39) 2-7-73
VERSION 16-2(38) 2-5-73 BY JRL MOD MP'S FOR SPROUT
VERSION 16-2(37) 1-28-73 BY JRL ALLOW ?,BIND TO MPPARS OUTSIDE OF FOREACH
VERSION 16-2(36) 1-23-73 BY JRL REMOVE RESTRICTION ABOUT MP WITH SAME ACTUAL ? PAR TWICE
VERSION 16-2(35) 11-30-72 BY RHT MODIFY LOPSS TO CALL EPOLL
VERSION 16-2(34) 11-28-72 BY RHT INSERT EXEC FOR CLEANUP
VERSION 16-2(33) 11-13-72 BY RHT BUG #KD# RECURSIVE CORTMP IN ADRINS
VERSION 16-2(32) 11-11-72 BY RHT BUG #KB# BAD LPSA ENCLOBERMENT IN SYNTUP
VERSION 16-2(31) 10-21-72 BY JRL CHANGE FIX TO BUG JT
VERSION 16-2(30) 10-20-72 BY JRL BUG #JT# DON'T RELEASE SETS TO BE RETURNED BY FUNCTION
VERSION 16-2(29) 10-13-72 BY JRL SAV MP RETURN VAL OVER CALL TO STKUWD
VERSION 16-2(28) 10-3-72 BY JRL BUG #JK# SAVE AC 1 OVER CALLS TO RECLAIM VALUE SET
VERSION 16-2(27) 10-3-72 BY JRL MOVE DEF OF MPFLAG TO STATS
VERSION 16-2(26) 9-21-72 BY JRL MAKE SURE PROC FORMALS CAN BE ACCESSED
VERSION 16-2(25) 9-18-72 BY KVL TO ADD SPECIAL CHECK: REF PARAMS TO PROC ARGS OF PROCS.
VERSION 16-2(23) 9-8-72 BY JRL HANDLE ? LOCAL ITEMVARS AS PARAMETERS TO PROCS
VERSION 16-2(22) 8-23-72 BY RHT ONLY ALLOCATE PD SEMBLK IF NOT SIMPLE
VERSION 16-2(21) 8-19-72 BY JRL HANDLE ? PARAMS TO FOREACH
VERSION 16-2(20) 8-17-72 BY JRL ALTER ISUCAL TO HANDLE MATCHING PROCEDURES
VERSION 16-2(19) 7-26-72 BY RHT BUG #IS# NEEDNEXT WHILE LOOPS
VERSION 16-2(18) 7-18-72 BY RHT BUG #IP# SET VALUE PARAMS RELEASING
VERSION 16-2(17) 7-6-72 BY RHT BUG ##I#K# FIX DL LOADING BUG IN ISSUE
VERSION 16-2(16) 7-4-72 BY RHT MAKE DONE & CONTINUE STORE TEMPS BEFORE JUMPING
VERSION 16-2(15) 7-4-72 BY RHT DONE, NEXT, &CONTINUE
VERSION 16-2(14) 6-27-72 BY JRL BUG #HZ# ARRTRAN UPSET BY LSTBIT
VERSION 16-2(13) 6-23-72 BY RHT FIX NEEDNEXT BUG
VERSION 16-2(12) 6-23-72 BY RHT FIX NEEDNEXT BUG
VERSION 16-2(11) 6-14-72 BY JRL BUGS #HR#,#HS# STRING ITEMVAR PARAMS, AND PROCS.
VERSION 16-2(10) 6-14-72 BY DCS BUG #HT# SAVE REGS, RF, RESTORE RF ON F4 SUBROUTINE CALL
VERSION 16-2(9) 6-14-72 BY RHT PUT IN DONE OUT OF FOREACH IN SIMP PROC
VERSION 16-2(8) 6-13-72 BY DCS BUG #HQ# ALLOW RETURN OF STRING ITEMVARS
VERSION 16-2(7) 6-9-72 BY RHT MAKE DONE IN FOREACH CALL ON BEXIT
VERSION 16-2(6) 5-31-72 BY JRL FIX BUG #HM# DRYROT STRING PARAMS TO MESSAGE PROCEDURES
VERSION 16-2(5) 5-24-72 BY RHT MORE GO TO SOLVING
VERSION 16-2(4) 5-24-72 BY rht make trago look at pda of label
VERSION 16-2(3) 5-14-72 BY DCS BUG #HG# CONSTANT BOOLEANS DIDN'T WORK WITH /H
VERSION 16-2(2) 5-11-72 BY DCS BUG #GW# DON'T CALL AT COMPTIME IF WRONG #PARAMS
VERSION 16-2(1) 5-11-72 BY DCS BUG #GU# NEGAT PROBLEM WITH LIMIT OF FOR ... UNTIL
VERSION 15-6(10) 3-15-72 BY RHT FIX SIMPSW BUGS
VERSION 15-6(9) 3-10-72 BY RHT TO FIX NNEDNEXT WHILE LOOPS
VERSION 15-6(8) 3-6-72 BY RHT FIX SIMPLE BUG
VERSION 15-6(7) 3-6-72 BY RHT FIX SIMPLE PROC DECL BUG
VERSION 15-6(6) 3-6-72 BY RHT fix trago bug
VERSION 15-6(5) 3-1-72 BY DCS CALL RUNTIME FUNCS (CONST ARGS) AT COMPTIME
VERSION 15-2(4) 2-6-72 BY DCS BUG #GP# CHECK FORWARD FORMALS AGAINST THE REAL ONES
VERSION 15-2(3) 2-6-72 BY DCS BUG #FV# CASE N ... ["A"] BLEW
VERSION 15-2(2) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
COMMENT ⊗For-Loop, Case Statement Variables⊗
LSTON (STATS)
ZERODATA (LOOP/CASE STATEMENT VARIABLES)
;CASTAK -- PCNT values for each statement of a Case Statement or
; Expression are stored here via QPUSH (CASTAK is a Q-Descriptor).
; These are used for setting up the Case dispatch table for
; the statement
↓CASTAK: 0
;FORLIS -- QSTACK Descriptor -- each entry is a saved FRBLK,
; put here when an inner Loop statement is started. See
; FRBLK for contents
↓FORLIS: 0
;FRBLK -- Semantics of current FOR-type loop. See LOOP DSCRs
; for details of its contents
↓FRBLK: 0
;FRDO -- class index from PARSER (via AC B), telling what kind of loop
↓FRDO: 0
↓FRTYPE: 0 ;LOOP TEMP VARIABLE
;NETTMP -- set if this is a NEEDNEXT loop -- coroutine-like code
; must be generated
↓NETTMP: 0
ENDDATA
COMMENT ⊗ Descriptions of For Loop Constructs, Bit Definitions⊗
BEGIN LOOP
DSCR FORBG, WAIT, FRSTE, FRLOP, WHIL, DOLOOP, etc.
PRO FORBG WAIT FRSTE FRWHIL FRSTO FRLIST FRLOP WHIL DOLOOP
PRO LOPPS DOUNT DNEXT DDONE
DES These are the generators for any of the looping constructs.
When the construct is recognized at statement level, a block
is created and attached to the Semblk for the loop descriptor
(FORC, WHILC, FOREACH).
Appropriate routines are called to generate the loop header code.
The Single routine LOPPS is called at the end of the loop range.
It generates the return jump (and the ADD to the index variable,
if a FOR loop) and deletes the Semblk squandered for the interim
purposes of holding AC numbers, fixups, and the like.
The syntactic contexts of the calls to these routines are:
FOR IVB ← FORBG
SG E STEP WAIT
SG E UNTIL/WHILE WAIT
FORC LHS E STEP E UNTIL E SG FRSTE
FORC LHS E STEP E WHILE E SG FRWHIL
FORC LHS E SG FRSTO
FRLIST a for list seen
FRLOP a DO seen
WHILE BE DO WHIL
DO DOLOOP (at statement level)
DOL S UNTIL BE DO DOUNT
@LOOP S END LOPPS
NEXT DNEXT
DONE DDONE
⊗
DSCR -- Loop statement Semblk Format
RES The block that is appropriated for use holding things has the
following format:
$DATA xwd fixup to jump out,,address to jump back to.
$DATA2 good bits word for this looping statement.
$DATA3 fixup for any DONE's done.
$ACNO ac number for the FOR index
$DATA4 xwd pointer to step,, pointer to index.
$ADR fixup to start of statement (after that, the actual address)
$VAL level of forloop start,,0
$VAL2 pcnt for start of whole thing (used for coroutines).
Following are good bits stored in $DATA2 for my use in sorting out
the 10↑6 cases for FOR loops and friends:
⊗
BITDATA (FOR-LOOP SEMBLKS)
↑JSPDON←← 1 ;There was a push done at some point (corout or flist)
INCNST←← 2 ;Step element is constant.
INPOS ←← 4 ;Step element is positive.
INONE ←← 10 ;Step element is +- 1
DOUNB ←← 20 ;DO <s> UNTIL <be> ;
FSTAT ←← 40 ;FOR <id> ← <e> STEP <e> UNTIL <e>
LWHIL ←← 100 ;WHILE <be> DO
↑FRCHS ←← 200 ;FOREACH x,y ....
↑FLIST ←← 400 ;For lists in progress.
↑COROUT←← 1000 ;The guy is going to try to use the NEXT thing.
NOJMPS←← 2000 ;There are no jumps out or back!
NOJRST←← 4000 ;This is a thing without a jump out (i.e. ID←E,E do)
NOMARK←← 10000 ;Do not mark index for storing on exit -
; either an itemvar or it was a for step while
;which may clobber the index
; but will store it at any rate!
↑TMPUS←← 20000 ;A temp was used in a for statement. Do not allow
;loser to jump into the for loop.
IXVAR ←← 40000 ;INDEXED VAR FOR CONTROL VAR.
DONDON ←← 200000 ;A "DONE" WAS EXECUTED IN THIS LOOP, THE CONTROL
;VARIABLE MUST NOT BE ASSUMED CORRECT IN THE AC
; AT LOOP END (SEE MARKIT -- DCS -- 8/2/70)
ENDDATA
COMMENT ⊗ FOR, DO, WHILE, NEEDNEXT Generators⊗
↑FRCHT: SKIPA TBITS,[FRCHS] ;FOREACH LIST STARTER.
↑DOLOOP: ;HERE ON START OF "DO"
MOVEI TBITS,DOUNB
JRST RECORDIT ;GO MAKE A BLOCK.
↑WHIL1: ;START OF "WHILE"
SKIPA TBITS,[XWD 0,LWHIL]
↑FORBG: ;START OF "FOR"
MOVEI TBITS,FSTAT
RECORDIT: PUSHJ P,ALLSTO ;CLEAR THE BOARDS
HRRO A,FRBLK ;LEFT HALF NEGATIVE.
QPUSH (FORLIS) ;PUSH ON THE OLD FRBLK VALUE.
GETBLK ;AND GET A NEW ONE.
MOVE A,LEVEL ;RECORD THE CURRENT LEVEL.
HRLM A,$VAL(LPSA) ;AND SAVE.
AOS LEVEL ;SO THAT TRAGO WILL SEE US.
SKIPN NETTMP ;COROUTINE FEATURE ASKED FOR ?
JRST NOCORT ;NO COROUTINES TODAY.
TRO TBITS,COROUT!JSPDON ;MARK IT AS SO.
TRNE TBITS,LWHIL
JRST [
MOVE SP,LPSA ;FOR THE ROUTINE TO FOLLOW
PUSH P,TBITS
PUSH P,LPSA
PUSHJ P,GTJSPR ;KNOW WE HAVE TO GET A JSP REG
POP P,LPSA ;RESTORE LPSA
POP P,TBITS
JRST .+1]
MOVE A,PCNT ;CURRENT PC.
HRRM A,$VAL2(LPSA) ;AND FIXUP FOR THE JSP
TRNE TBITS,DOUNB ;COROUTINE DISALLOWED FORTHIS
ERR <NO COROUTINES HERE, PLEASE>,1
SETZM NETTMP ;FOR NEXT TIME. (PUN, PUN)
NOCORT: MOVE A,PCNT
MOVEM A,$DATA(LPSA) ;SAVE FOR START OF WHILE.
MOVEM TBITS,$DATA2(LPSA) ;STORE BITS.
MOVEM LPSA,FRBLK ;SAVE FOR INTERESTED PARTIES.
MOVEM LPSA,GENRIG ;FOR THE DOLOOP.
TRNE TBITS,FRCHS
TRNN TBITS,COROUT
POPJ P,
MOVE SP,LPSA
PUSHJ P,GTJSPR ;IF FOREACH COROUTINE, DO MOVEI NOW
MOVE LPSA,SP
POPJ P,
↑NEXTR: ;HE IS GOING TO ASK FOR NEXT.
SETOM NETTMP
POPJ P,
↑ENDFOR: PUSHJ P,INIT ;FINISH OUT FOREACH CODE.
JRST DOL1 ;NO JUMP BACK, PLEASE.
;;#NI# RHT 30-JULY-73 NEED A FIXUP FOR CONTINUES
↑CNFXP: MOVE SP,FRBLK ;
HLLZ B,$ACNO(SP) ;FIXUP TO THE TEST
JUMPE B,.+4 ;NO FIXUP
PUSHJ P,ALLSTO ;
HRR B,PCNT ;YES FIXUP
PUSHJ P,FBOUT ;
POPJ P,
;;#NI#
↑DOUNT: ;HERE ON DO S UNTIL....
PUSHJ P,STIF ;GO EVALUATE BOOLEAN.
; MOVE B,GENRIG ;RESULTANT FIXUP.
MOVE SP,FRBLK
HRR B,$DATA(SP)
;;#HG#2↓ 5-14-72 DCS (3-4) TEST ENTIRE LEFT HALF OR /H WON'T WORK
HLRE TEMP,B ;IF LH IS -1, WE HAVE
AOJE TEMP,DONON ; `DO S UNTIL TRUE', DO ONLY ONCE
PUSHJ P,FBOUT ;PUT OUT FIXUP.
JRST DONON ;FREE THE BLOCK, ETC.
↑WHIL: ;ALL DONE WITH A WHILE STATEMENT.
SETZM FRDO
PUSHJ P,STIF ;GO EVALUATE THE BOOLEAN EXPRESSION.
PUSHJ P,INIT ;GET GOOD BITS.
; MOVE B,GENRIG ;THE HORRID TRUTH.
HLLM B,$DATA(SP) ;FIXUP FOR JUMP OUT, LH -1 IF TRUE
JRST DOL ;GO MAKE CALLS IF NECESSARY.
↑LFOR: ;HERE FROM LEAP STUFF.
PUSHJ P,INIT ;GET SET UP, AND FILL UP "C";
HRRM PNT,$DATA4(SP) ;INDEX ... FOR WHAT IT IS WORTH.
PUSHJ P,ALLSTO ;STORE EVERYONE.
TRO C,NOMARK ;WE DO NOT MARK THE INDEX ON EXIT.
JRST FRS1 ;GO SEE ABOUT CALLS.
↑FRSTO: ;WE HAVE SEEN A <ID> ← E , OR <ID> ← <E> DO.
MOVEM B,FRDO ;B HAS INDEX FROM PARSER.
SOSL B,THISE ;SEE WHAT KIND OF EXPRESSION
JRST [JUMPN B,LPFRSTO ;LEAP
PUSHJ P,LEVBOL ;BOOLEAN
JRST .+1]
PUSHJ P,GETINDX ;PICK UP THE INDEX, START VALUE AND SAVE.
PUSHJ P,FORST ;GO DO THE STORE.
FRS1: TRNN C,FLIST ;IF LIST NOT GOING, THEN
SKIPE FRDO ;IF THIS IS THE LAST
JRST DOL1
TRO C,NOJMPS ;DO NOT EMIT ANY JUMPS.
JRST DOL1 ;GENERATE CALLS IF NECESSARY.
↑WAIT: ;HERE ON "STEP" OR "UNTIL/WHILE"
JUMPE B,GETINDX ;FOR "STEP", JUST RECORD THE INDEX INFO.
JUMPL B,CPOPJ ;NOTHING DOING !
CAILE B,2 ;IF NOT UNTIL/WHILE
POPJ P, ;GO AWAY.
;DCS 8/16/70 CONVERT TYPE OF INCR
MOVE TEMP,FRBLK ;ALL INFO WE HAVE ABOUT LOOP SO FAR
HRRZ TEMP,$DATA4(TEMP) ;SEMANTICS OF INDEX VARIABLE
HRR B,$TBITS(TEMP) ;TYPE
MOVE PNT,GENLEF+1 ;INCREMENT SEMANTICS
GENMOV (CONV,INSIST!GETD) ;MAKE SURE THEY MATCH
MOVEM PNT,GENLEF+1 ;FIXUP
;DCS 8/17/70
PUSHJ P,FORST ;GO HANDLE THE STORE.
MOVE PNT,GENLEF+1 ;INCREMENT.
PUSHJ P,CLEAR ;MAKE SURE OUT OF AC.
PUSHJ P,GETAD ;NOW GET SEMANTICS
TLNE SBITS,CORTMP ;IF A TEMP, THOUGH, BE SURE
TRO C,TMPUS ; NOT TO LET JUMPS COME INTO THE LOOP.
GENMOV (CONV,INSIST) ;B STILL LEFT OVER FROM FRSTO.
QPUSH (FORLIS,PNT)
TRZ C,INONE!INCNST!INPOS ;IN CASE WE COME THROUGH HERE THE SECOND
;TIME WHEN PUTTING OUT FOR LISTS.
TLNN TBITS,CNST ;IF STEP IS CONSTANT, THEN COMPUTE SOME THINGS.
JRST NOCVN
TRO C,INCNST ;ASSERT CONSTANT.
SKIPL $VAL(PNT) ;SEE ABOUT VALUE.
TRO C,INPOS ;ASSERT POSITIVE.
MOVM TEMP,$VAL(PNT) ;SEE ABOUT VALUE EQUAL TO 1.
CAIN TEMP,1
TRO C,INONE ;IT IS ONE!
NOCVN: ;PLACE TO JUMP BACK TO IN ORDER TO
;COMPUTE LIMIT.
HRRM TBITS2,$DATA(SP) ;SINCE STOREB WAS DONE, NOW AC INFO IS ASSUMED
HRLM PNT,$DATA4(SP) ;SAVE INCREMENT.
JRST FINOUT ;SAVE C AND EXIT.
STJSPR: PUSHJ P,INIT
TRNN C,COROUT ;IS IT A COROUTINE ????
POPJ P, ;NO !!!!!!!
HLRZ D,$ADR(SP) ;PICK UP AC NO
JUMPN D,HAVAC ;IF NOT FIRST TIME, THEN GET THE AC NO NOW
GTJSPR: PUSHJ P,GETAN0 ;GET THEE AC
PUSHJ P,MARKINT ;MAKE IT AN INTEGER TEMP
HRLM PNT,$VAL2(SP) ;SAVE THE TEMP
HRLM D,$ADR(SP) ;REMEMBER AC NUMBER
HRRZ PNT,SP ;
EMIT <MOVEI JSFIX> ;
POPJ P, ;
HAVAC: HLRZ PNT,$VAL2(SP) ;PICK UP THE TEMP
CAIN PNT,0 ;IS IT THERE
ERR <DRYROT AT WAIT>;NO
GENMOV (GET,GETD!SPAC!MRK)
HRLM PNT,$VAL2(SP) ;PUT IT AWAY -- NOW KNOW AC IS LOADED FOR
;COROUTINE CALL
POPJ P,
FORST: ;ROUTINE TO HANDLE THE STORES.
;;#IS# ↓ RHT 7-26-72 NEEDED TO BE SURE MOVEI AC,START IS DONE
PUSHJ P,STJSPR ;INIT, SET UP TEMP IF COROUT
HLRZ PNT,$DATA4(SP) ;EXPRESSION FOR START
HRRZ PNT2,$DATA4(SP) ;AND INDEX.
HLRZ D,$ADR(SP) ;PICK UP AC FOR COROUT OR JSP
TRNE C,COROUT!JSPDON ;IF WE HAVE ONE
HRROS ACKTAB(D) ;PROTECT IT
PUSHJ P,FORSTO ;SPECIAL GOSTO LIKE (A LA BOLSTO)
;THE POINT OF ALL THIS IS TO STORE ANY INCREMENT
;CALCULATIONS DONE. (I.E. TEMPS).
;BUT WE TRY TO KEEP START EXPR IN AC.
CAIE D,0 ;DID WE PROTECT SOMEONE?
HRRZS ACKTAB(D) ;YES -- WITHDRAW PROTECTION
PUSHJ P,GETAD2 ;GET SEMANTICS. OF INDEX
; TLNE SBITS2,INDXED!FIXARR
; TRO C,IXVAR ;INDEXED.
TLNN SBITS2,PTRAC ;IS IS INDXED (SHUDDER) ?
JRST .+3
HRRZ D,$ACNO(PNT2)
PUSHJ P,STORA ;GO STORE IT.
; HLRZ PNT,$DATA4(SP) ;STARTER VALUE IN PNT.
PUSHJ P,GETAD
HRRI FF,INSIST!INDX!POSIT!REM ;ALL THESE THINGS.
SKIPE D,$ACNO(SP) ;OLD DUSTY AC ?
TRO FF,SPAC ;YES -- AND MORE.
HRRZ B,TBITS2 ;TO FORCE TYPE CONVERSION TO INDEX TYPE.
GENMOV (GET) ;MAGIC
MOVE TBITS,PCNT ;REMEMBER PROGRAM COUNTER.
;(NOTE EXCHOP IN NEXT INSTR)
;;#MV# RHT USE TO BE A GENMOV PUT ONLY
GENMOV (ACCESS,EXCHIN) ;MARK FOR STORE -- ACTUALLY STORE IF THE
;THING WAS INDXED.
GENMOV (PUT,0) ;
;;#MV#
MOVEM D,$ACNO(SP) ;NEW AC# IF ANY.
MOVEM B,FRTYPE ;SAVE TYPE FOR THIS LIST.
POPJ P,
GETINDX: ;PICK UP INDEX AND STARTERD....
MOVE SP,FRBLK ;GET CURRENT BLOCK.
MOVE A,GENLEF+2 ;INDEX
HRL A,GENLEF+1 ;STARTER
MOVEM A,$DATA4(SP)
POPJ P, ;DONE
COMMENT ⊗ (continued), NEXT, DONE, CONTINUE⊗
↑FRWHILE: ;HERE ON FOR-STEP-WHILE
MOVEM B,FRDO ;INDEX FROM PARSER.
PUSHJ P,STIF ;EVALUATE THE BOOLEAN
; MOVE B,GENRIG ;FALSE FIXUP
PUSHJ P,INIT
HLLM B,$DATA(SP) ;FIXUP FOR JUMP OUT.
TRNE C,FLIST!COROUT ;ONLY IF STATEMENT BEING PUSHJ'ED TO, DO WE
PUSHJ P,INDXGET ;GET THE INDEX BACK IN THE RIGHT AC.
TRO C,NOMARK ;DO NOT MARK INDEX AC ON EXIT -- STIF STORED IT.
JRST DOL ;SEE ABOUT CALLING THE STATEMENT.
↑FRSTE: ;HERE ON FOR-STEP-UNTIL
MOVEM B,FRDO ;INDEX FROM PARSER.
PUSHJ P,INDXGET ;GET INDEX BACK IN THE AC.
MOVE B,FRTYPE
;;#GU# 5-11-72 DCS NEGAT BUG FIX
GETSEM (1) ;LIMIT
TLNN SBITS,NEGAT ;DO WE HAVE TO DO IT?
JRST LIMOK ; NO, GOOD
PUSH P,D
GENMOV (GET,PROTECT!INSIST!POSIT!UNPROTECT) ;GET RIGHT GUY
POP P,D
JRST NOWOK ;NOW IT'S OK
LIMOK: GENMOV (ACCESS,PROTECT!INSIST!UNPROTECT) ;BLESS IT
;;#MJ SAVE CONVERTED SEMBLK FOR LATER REMOP
MOVEM PNT,GENLEF+1
;;#GU#
NOWOK: TRNE C,INCNST ;IS INCREMENT CONSTANT ?
JRST FRCNST ;YES -- DO OTHER THINGS.
HRL C,D
PUSHJ P,GETAN0 ;WE WOULD OTHERWISE CLOBBER PROTECTED AC.
EMIT (MOVE USADDR!NORLC)
MOVSI A,(<SUB>) ;SUBTRACT INDEX-LIMIT
TRNN TBITS,INTEGR ;CORRECT ?
MOVSI A,(<FSB>)
PUSHJ P,EMITER ;AC NOW HAS INDEX - LIMIT.
MOVS PNT,$DATA4(SP) ;INCREMENT.
EMIT (SKIPL NOUSAC) ;SKIPL INCREMENT
HRL C,D ;GET AC #
EMIT (MOVNS NOUSAC!USADDR!NORLC)
MOVE A,[JUMPL NOADDR];THE JUMP OUT.
JRST REMTMP
FRCNST: MOVSS C ;BECAUSE WE NEED CONDITION BITS.
HRRI C,3 ;CODE FOR ≤
TLNN C,INPOS ;ASSUMPTION CORRECT?
HRRI C,5 ;CODE FOR ≥
MOVE A,[CAM USCOND] ;THE SUPER COMPARE INSTRUCTION.
PUSHJ P,EMITER
MOVSS C
MOVE A,[JRST NOUSAC!NOADDR]
REMTMP: MOVE TEMP,PCNT ;PROGRAM COUNTER OF THE JRST.
HRLM TEMP,$DATA(SP) ;SAVE IT.
PUSHJ P,EMITER
MOVE D,$ACNO(SP) ;GET BACK AC NUMBER
MOVE LPSA,GENLEF+1 ;LIMIT
PUSHJ P,REMOPL ;ALL DONE WITH IT.
DOL: TRZA C,NOJRST ;INDICATE THAT ADD'S ARE TO BE DONE.
DOL1: TRO C,NOJRST ;INDICATE NOT AN ADDITIVE FOR STATEMENT.
;NOW GENERATE CALLS TO STATEMENT IF NECESSARY.
TRNN C,COROUT!FLIST ;THESE ARE THE INTERESTING CASES.
JRST FINTO
TRNE C,COROUT ;COROUTINE ?
PUSHJ P,CRCAL ;CALL IT.
TRNN C,COROUT ;IF ONLY A FOR LIST, THEN
PUSHJ P,FLSCAL ;CALL IT.
ENDIT:
LEP <
TRNE C,FRCHS ;FOREACH ?
JRST [PUSH P,C
LPCALL (FRLOOP)
POP P,C
JRST LSTTST]
>;LEP
TRNE C,NOJRST!NOJMPS ;IF NOT ADDING LOOPING STATEMENT,
JRST LSTTST ;GO SEE ABOUT FIXUPS AND THINGS.
TRNN C,FSTAT ;IF NOT FOR STATEMENT, THEN EMIT THE JRST
JRST [ ;BACK TO THE BEGINNING.
HRL C,$DATA(SP)
EMIT (JRST NOUSAC!USADDR)
JRST LSTTST]
ADDIT: HRRZ D,$ACNO(SP) ;MAY HAVE BEEN MANGLED BY COROUT STUFF
;NOW IS THE TIME TO PUT OUT THE ADDS AND THINGS.
TRNE C,INONE ;IS INCREMENT CONSTANT AND ONE ?
JRST ACCDOM ;YES
HLRZ PNT,$DATA4(SP) ;INCREMENT.
;;#MH# ↓ RHT 5-12-73 WAS GETAD BUT REALLY NEED ACCESS
GENMOV (ACCESS,GETD)
MOVSI A,(<ADD>)
TRNN TBITS,INTEGR ;IS THIS CORRECT ?
MOVSI A,(<FADR>)
PUSHJ P,EMITER
MOVE A,[JRST NOUSAC!USADDR]
JRST EJRT ;TO EMIT IT.
ACCDOM: MOVE A,[AOJA USADDR]
TRNN C,INPOS
HRLI A,(<SOJA>)
EJRT: HRL C,$DATA(SP) ;JUMP BACK.
PUSHJ P,EMITER ;EMIT IT.
LSTTST:
SKIPN FRDO ;WAS THIS THE LAST ?
JRST FLTEST ;YES -- GO SEE ABOUT FOR LISTS.
TRNE C,NOJRST ;JUMPS BACK?
JRST FINTO
HLLZ B,$DATA(SP) ;FIXUP FOR JUMP OUT.
HRRZS $DATA(SP) ;RESTART IT.
HRR B,PCNT
PUSHJ P,FBOUT
JRST FINTO ;FIXUP DONE -- GO AWAY.
FLTEST: TRNE C,NOJRST!COROUT ;IF ALREADY A JUMP OUT OR
TRNN C,FLIST!COROUT ;NO FOR LIST GOING AND NO COROUTINE
JRST STAT ; -- RECORD START OF STATEMENT.
HRRZ B,PCNT ;NONE -- NEED TO PUT IN JRST
TRNE C,COROUT ;COROUTINE??
JRST [
HLL B,$DATA(SP) ;FIXUP FOR THE JUMPS TO EXIT
TLNE B,-1 ;IF ANY
PUSHJ P,FBOUT ;
HRRZS $DATA(SP) ;START OVER
HLRZ D,$ADR(SP) ;JSP REGISTER
GENMOVE(GET,GETD!SPAC!POSIT);
HRLZ D,D
HRLI C,1
EMIT <JRST NOUSAC!NORLC!USX!USADDR>
JRST STAT
]
HRLM B,$DATA(SP) ;MAKE A FIXUP FOR JUMP OUT.
EMIT <JRST NOUSAC!NOADDR>
STAT: TRNN C,COROUT!JSPDON ;COROUTINE OR FOR LIST -- IE A JSP THING
JRST STAT.1 ;NO
HRLZ B,PCNT ;PICK UP PCNT
HLRM B,$DATA3(SP) ;REMEMBER WHERE
HLRZ PNT,$VAL2(SP) ;THIS TEMP
PUSHJ P,REMOP ;IS NOW KAPUT
HLRZ D,$ADR(SP) ;PICK UP THE AC
PUSHJ P,MARKINT ;NEW TEMP
HRLM PNT,$VAL2(SP) ;SAVE IT
TRNE C,COROUT ;IF COROUTINE
JRST FINTO ;THE "START" IS AT THE END (SO SKIP RETURN WORKS)
STAT.1: HRLZ B,$ADR(SP) ;SAY THAT THIS IS THE START
HRR B,PCNT ;THIS IS THE START OF STATEMENT.
TLNE B,-1
PUSHJ P,FBOUT
FINTO: SKIPE FRDO ;IF NOT LAST, THEN DON'T RECORD.
JRST FINOUT
MOVEM SP,GENRIG ;RECORD BEFORE GOING AWAY.
MOVEM SP,GENRIG+2 ;.....
FINOUT: MOVEM C,$DATA2(SP) ;SAVE C
POPJ P, ;AND EXIT.
FLSCAL: MOVE PNT,SP ;FOR LIST CALL.
TRO C,JSPDON
PUSH P,D ;DO I REALLY NEED TO?????????
HLRZ D,$ADR(PNT) ;
JUMPN D,EMTIT
PUSH P,PNT
PUSHJ P,GETAN0 ;
PUSHJ P,MARKINT
HRLM D,$ADR(SP);
HRLM PNT,$VAL2(SP);
POP P,PNT
EMTIT:
EMIT <JSP JSFIX>
POP P,D
POPJ P,
CRCAL:
HLRZ PNT,$VAL2(SP) ;TEMP SEMBLK
HLRZ D,$ADR(SP) ;AC NO
SKIPE TEMP,ACKTAB(D) ;WHAT IT THINKS IS THERE
CAIN PNT,(TEMP) ;IF NOTHING OR SAME THING
JRST TRISOK ;THEN DONT NEED TO
GENMOV (GET,GETD!SPAC!POSIT);GET IT THERE
TRISOK: EMIT <JSP INDRCT> ;CALL IT
POPJ P,
INIT: MOVE SP,FRBLK
SKIPE BNFG ;WANT A NAMED BLOCK??
PUSHJ P,FNLBK ;YES
MOVE C,$DATA2(SP) ;GOOD BITS WORD.
SKIPE FRDO ;FOR LIST (I.E. A COMMA)?
TRO C,FLIST ;RECORD THIS FOR ALL TIME.
MOVE D,$ACNO(SP) ;SET UP PRIVILEGED AC NUMBER.
POPJ P,
↑LOPPS: ;HERE AT END OF STATEMENT.
PUSHJ P,INIT
HLLZ B,$ACNO(SP) ;ANY "CONTINUE" FIXUPS DONE HERE
JUMPE B,DSTQQ
MOVE PNT,ACKTAB(D) ;IF (D) STILL HOLDS THE INDEX, THEN PROTECT
HRRZ PNT2,$DATA4(SP) ; WHAT I THINK INDEX IS
CAIN PNT2,(PNT)
HRROS ACKTAB(D)
PUSHJ P,ALLSTO
HRRZS ACKTAB(D)
HRR B,PCNT ;DO THE CONTINUE FIXUP NOW
PUSHJ P,FBOUT
DSTQQ: PUSHJ P,STORQQ ;STORE EVERYONET RELEVANT.
;BUT PERHAPS NOT THE INDEX.
SKIPLE POLINT ;DO WE WANT POLLS INSERTED?
PUSHJ P,EPOLL ;YES -- CALL TO SAVE ALL REGS
TRNE C,FLIST!COROUT ;ANY OF THESE THINGS ?
JRST HARDER ;YES -- ADDS ALREADY DONE.
PUSHJ P,ENDIT ;SEE ABOVE -- EMIT THE ADDS.
JRST MARKIT ;GO MARK THE AC, EMIT JUMP FIXUPS.
HARDER: TRNN C,COROUT ;COROUTINE??
JRST [HLRZ PNT,$VAL2(SP)
EMIT <JRST NOUSAC!INDRCT> ;NO
PUSHJ P,REMOP ;FLUSH IT
JRST MARKIT
]
PUSHJ P,CRCAL ;COROUTINE CALL
HRLZ B,$ADR(SP) ;THE "START" IS HERE
HRR B,PCNT
PUSHJ P,FBOUT
HRL C,$DATA3(SP) ;REAL START OF LOOP ADDRS
EMIT <JRST NOUSAC!USADDR>
HLRZ PNT,$VAL2(SP) ;WE DONT NEED HIM ANY MORE
PUSHJ P,REMOP
MARKIT:
JUMPOUT:
; TRNN C,IXVAR ;IF INDEXED VAR.
; JRST .+3
; PUSHJ P,REMOPA ;CLEAR OUT AC TABLE ENTRY.
; SETZM ACKTAB(D)
TRNE C,NOMARK ;IF HE REALLY DIDN'T WANT THE THING MARKED
PUSHJ P,CLEARA ;WIPE OUT THE AC.
TRNE C,DONDON ;DID SOMEBODY JUMP OUT VIA "DONE"?
PUSHJ P,CLEARA ;YES, WIPE OUT AC (DCS -- 8/2/70)
JMGO: TRNE C,NOJMPS ;IF NO JUMPS WERE DONE,
JRST ALDON ;THEN ALL DONE
HLL B,$DATA(SP) ;PLACE TO JUMP OUT.
HRR B,PCNT ;
;;#HG#2↓ 5-14-72 DCS (4-4) TEST ENTIRE LEFT HALF, OR /H WON'T WORK
HLRE TEMP,B ;If left half is -1,
AOJE TEMP,DONON ; there was no JRST FALSE (BE was TRUE)
PUSHJ P,FBOUT ;FIXUP TO JUMP OUT.
DONON: HLLZ B,$DATA3(SP) ;"DONE" FIXUP
JUMPE B,ALDON ;THESE HAVE FINISHED.
HRR B,PCNT
PUSHJ P,FBOUT
ALDON: FREBLK <SP> ;GOING,
SOS LEVEL
POPER: QPOP (FORLIS) ; GOING,
JUMPL A,DONER ;REMOPS DONE.
MOVE PNT,A
PUSHJ P,REMOP
JRST POPER
DONER:
HRRZM A,FRBLK ; GOING,
POPJ P, ; GONE.
↑DDONE: ;HERE ON "DONE" CONSTRUCT
SKIPN SP,FRBLK
ERR <"DONE" ILLEGAL OUTSIDE LOOP>,1,DDPOPJ
DONEXX: PUSHJ P,GOSTO ;IT IS SAME AS A GO TO
MOVE B,LEVEL
HLRZ SBITS,$VAL(SP) ;LOOP LEVEL
MOVE C,$DATA2(SP) ;IF FOREACH STATEMENT, GO ONE MORE TO
TRNE C,FRCHS ;GET OUT OF THE FAKE BLOCK
SUBI SBITS,1
PUSHJ P,TRAGO
HRRZ C,$DATA3(SP) ;PROTECT RH FROM EXCH
HRL C,PCNT
EXCH C,$DATA3(SP) ;CHAIN FIXUPS FOR DONE.
MOVE TEMP,$DATA2(SP)
TRO TEMP,DONDON
TRZ TEMP,NOJMPS
MOVEM TEMP,$DATA2(SP)
EMIT (JRST NOUSAC!USADDR)
DDPOPJ: POPJ P,
↑DNEXT: ;HERE ON "NEXT" CONSTRUCT
PUSHJ P,STORQQ
NEXTXX: TRZ C,NOJMPS
HRRM C,$DATA2(SP)
TRNE C,COROUT ;ONLY ALLOW IF COROUTINE
JRST CTCOR ;GO CALL THE COROUTINE
ERR <USED NEXT WITHOUT PREPARATION>,1
POPJ P,
CTCOR: PUSHJ P,CRCAL ;CALL THE COROUTINE
PUSH P,PCNT
EMIT <JRST NOUSAC!NOADDR>
MOVE B,LEVEL
HLRZ SBITS,$VAL(SP)
MOVE C,$DATA2(SP) ;IF FOREACH STATEMENT, GO ONE MORE TO
TRNE C,FRCHS ;GET OUT OF THE FAKE BLOCK
SUBI SBITS,1
PUSHJ P,TRAGO ;SOLVE THE GO TO
HLLZ C,$DATA(SP) ;JUMP OUT
HRR C,PCNT ;FIXUP
HRLM C,$DATA(SP) ;
EMIT <JRST NOUSAC!USADDR>
POP P,B
HRLZ B,B
HRR B,PCNT
PUSHJ P,FBOUT
HLRZ PNT,$VAL2(SP) ;TEMP FOR COROUT VAR
HRLZI SBITS,INAC ;MARK IT INAC
ORM SBITS,$SBITS(PNT)
HLRZ D,$ADR(SP) ;THE ACNO
HRRZM D,$ACNO(PNT)
HRRZM PNT,ACKTAB(D) ;SAY AC IS FULL OF IT
POPJ P,
STORQQ: PUSHJ P,QQW
SKIPA PNT,[0]
HRRZ PNT,ACKTAB(D)
HLRZ PNT2,$VAL2(SP) ;DONT WIPE THESE OUT -- JSP TEMP
JRST BOLSTO
↑CNTNUE:
SKIPN SP,FRBLK ;FETCH FOREACH BLOCK
ERR <"CONTINUE" ILLEGAL OUTSIDE LOOP">,1,CCPOPJ
CONTXX: PUSHJ P,GOSTO ;SAME AS A GO TO
MOVE B,LEVEL
HLRZ SBITS,$VAL(SP) ;LOOP LEVEL
PUSHJ P,TRAGO ;SOLVE IT
HRL C,PCNT ;FIXUP
HRR C,$ACNO(SP) ;
EXCH C,$ACNO(SP) ;
EMIT <JRST NOUSAC!USADDR> ;JUMP TO LOOP END
CCPOPJ: POPJ P,
↑NEXTBN: ;NEXT -- WITH BLOCK NAME
SETOM BNFG ;SET A FLAG FOR INIT
PUSHJ P,STORQQ ;
SETZM BNFG ;
JRST NEXTXX ;
ZERODATA ()
BNFG: 0 ;FLAG TO TELL INIT TO FIND BLOCK NAME
ENDDATA
↑CONTBN: ;CONTINUE WITH BLOCK NAME
PUSHJ P,FNLBK
JRST CONTXX
↑DONEBN: ;DONE WITH BLOCK NAME
PUSHJ P,FNLBK
JRST DONEXX
FNLBK: ;FINDS THE NAMED LOOP BLOCK
;FIRST SEARCH FOR THE NAMED BLOCK
MOVE A,GENLEF
MOVE LPSA,$PNAME+1(A) ;THE REQUESTED NAME
MOVE TBITS2,PPSAV ;STACK POINTERS
MOVE SBITS2,GPSAV
LKNPE: HRRZ C,(TBITS2) ;PARSE ENTRY
CAME C,%NBEG ;A BEGIN???
JRST CHKILL ;NO
MOVE TEMP,(SBITS2) ;SEM ENTRY
CAME LPSA,$PNAME+1(TEMP) ;SAME???
JRST NXTBK ;NO
;HERE CHECK NEXT THING BACK TO SEE IF A LOOP
HRRZ C,-1(TBITS2) ;PICK UP
CAME C,%DOL ;
CAMN C,%WHILC
JRST OKBNM
CAME C,%ASSDO
CAMN C,%NFORC
JRST OKBNM
ERR <"DONE", "NEXT", OR "CONTINUE" TO A BLOCK NOT THE
BODY OF A LOOP >,1
EREXT: SKIPE BNFG ;FROM NEXT?
JRST [ POP P,(P) ;YES, TWO MORE LEVELS IN
POP P,(P)
JRST .+1 ]
POP P,(P)
POPJ P,
OKBNM: MOVE SP,-1(SBITS2) ;GET THE SEMANTICS INTO SP
POPJ P,
CHKILL: CAMN C,%NPDEC ;PROCEDURE DECL
JRST [ ERR <ATTEMPT TO "DONE", "NEXT", OR "CONTINUE" OUT OF PROCEDURE>,1
JRST EREXT ]
CAMN C,%NBLAT
JRST [ ERR <ATTEMPT TO "DONE", "NEXT", OR "CONTINUE" A BLOCK
THAT I CANT FIND>,1
JRST EREXT]
NXTBK: SOS TBITS2
SOJA SBITS2,LKNPE
STOREB: PUSHJ P,QQW ;DO IT.
JRST ALLSTO ;IF NOT FOR LOOP,STORE.
HRROS ACKTAB(D) ;PREPARE FOR STORES.
PUSHJ P,ALLSTO
HRRZS ACKTAB(D)
POPJ P,
INDXGET: TLOA FF,FFTEMP
QQW: TLZ FF,FFTEMP
PUSHJ P,INIT
TRNN C,FSTAT ;FOR STATEMENT?
POPJ P, ;NO GETTING TO BE DONE.
MOVE PNT,$DATA4(SP) ;INDEX.
PUSHJ P,GETAD
TRNE TBITS,STRING ;IF STRING,
POPJ P, ;ALL DONE.
PUSH P,SBITS ;SAVE.
GENMOV (GET,SPAC!POSIT) ;GET INDEX ......
POP P,TEMP ;RESTORE SBITS.
TLNN TEMP,INDXED!FIXARR ;IF THESE,
JRST NOIXX
TLZ TEMP,PTRAC!INAC ;....
MOVEM TEMP,$SBITS(PNT) ;RESTORE IT.
SETZM ACKTAB(D) ;AND....
NOIXX: TLNN FF,FFTEMP ;NOT IF JUST INDXGET.
AOS (P) ;SKIP RETURN.
POPJ P,
BEND LOOP
SUBTTL Land of Labels.
COMMENT ⊗ENTLAB, TRA -- generators for label placement, Go To statements⊗
BEGIN LABEL
DSCR ENTLAB, TRA
DES Execs for handling labels
For now, we are dealing with labels in the obvious way.
When in doubt, the poor loser cannot do the transfer he
requests. When we get more smarts, we can provide more features
(bugs?).
Semantic contexts:
ILB : ENTLAB
GOTO ILB TRA
SEE TRAGO DSCR, for the routine which does most of the work
(it is also used by RETURN, LOOP code)
⊗
↑ENTLAB: PUSHJ P,ALLSTO ;CLEAR THE BOARDS.
GETSEM (1)
MOVE LPSA,PNT
TRZN TBITS,FORWRD ;IT IS NO LONGER FORWARD.
ERR <LABEL ALREADY DEFINED:>,3
MOVEM TBITS,$TBITS(PNT)
HRLZ B,$ADR(PNT) ;FIXUP
JUMPE B,ENT1 ;HAS NOT BEEN USED YET.
HRR B,PCNT
PUSHJ P,FBOUT ;EMIT THE FIXUP.
ENT1: MOVE B,PCNT
HRRZM B,$ADR(PNT) ;THIS IS THE ADDRESS.
MOVE B,LEVEL ;THE LEVEL CURRENTLY AT.
PUSHJ P,TRAG1 ;SPECIAL -- TO GUARANTEE ACCESS.
TLNN FF,FFTEMP ;SUCCESSFUL ?
ERR <LABEL DEFINED AT LOWER LEVEL>,1
POPJ P, ;YES
↑TRA: PUSHJ P,GOSTO ;STORE EVERYONE -- HE MAY BE NEEDED
GETSEM (0) ;THE TARGET
MOVE B,LEVEL ;CURRENT LEVEL
HLRZ PNT2,$ACNO(PNT) ;PICK UP PDA SEMBK (MAY JUMP OUT OF PROC)
PUSHJ P,TRAGO ;DO THE WORK.
EMJRST: GETSEM (0) ;AGAIN
MOVE A,[JRST NOUSAC]
JRST EMITER ;ALL THROUGH.
COMMENT ⊗ TRAGO -- go-to-solver -- used also by RETURN code⊗
DSCR TRAGO, TRAG1 -- general complicated-jump solver
CAL PUSHJ from points within Label, Loop, RETURN code.
PAR AC B contains the LEVEL we are at.
AC SBITS contains the level we are trying to reach.
AC PNT2 POINTS AT TARGET PDA IF JUMP OUT OF PROC
DES TRAGO and TRAG1 search up the stack looking for syntactic
things that may need attention. If the level comparison indicates
putting out <ARRAY RELEASE> instructions, this is done. Note
that we disallow jumping out of a Procedure. Stack adjustment
many levels deep in recursion could be messy.
TRAG1 is called when a Label is finally defined to make sure of free
access from the level at which the label was "declared" to the level
at which it is finally defined. This prohibits jumping into certain
kinds of For Loops (those with stack problems), jumping into
Foreach statements, jumping into Blocks with Arrays dynamically
declared, etc.
⊗
ZERODATA(LOCAL NAMES FOR GO TO SOLVER)
BK: 0 ;SET TO SEMBLK FOR FIRST BLOCK OUT TO NEED EXITING
BL: 0 ;SET TO COUNT OF BLOCKS OUT TO GO
ENDDATA
BIT2DATA (BIT DEFS FOR GOOD GO TO SOLVING BITS)
ENDDATA
TRAG1: TLOA FF,FFTEMP
↑TRAGO: TLZ FF,FFTEMP ;B HAS LEVEL OF JUMP
LDB C,[POINT LLFLDL,SBITS,=35] ;C HAS LEVEL OF LABEL
SUB B,C ;B HAS NUMBER OF BLOCKS WE MUST GO UP.
JUMPE B,CPOPJ ;NO BLOCKS TO GO THROUGH.
SETZM BK ;ZERO PLACE KEEPERS
SETZM BL;
MOVE TBITS2,PPSAV
MOVE SBITS2,GPSAV ;PICK UP STACK POINTESS
TOK: HRRZ C,(TBITS2) ;PARSE ENTRY.
CAME C,%DOL ;DO S UNTIL BE.
CAMN C,%WHILC ;WHILE BE DO...
JRST .+3
CAME C,%ASSDO ;A FOREACH LOOP ?
CAMN C,%NFORC ;A FOR LOOP ????
JRST [
MOVE TEMP,(SBITS2) ;SEMANTICS
MOVE TEMP,$DATA2(TEMP); GOOD BITS
NOLEP <
TRNN TEMP,COROUT!FLIST
>;NOLEP
LEP <
TRNN TEMP,COROUT!FLIST!FRCHS
>;LEP
JRST LGOUP ;NOTHING EXCITING
TLZE FF,FFTEMP ;LOSE IF COMING IN
POPJ P,
JRST LGOUP
]
TRYAL: CAMN C,%NBEG ;MIGHT IT BE A BLOCK
JRST DOBLK ;TREAT IT AS A BLOCK
CAME C,%BLKFRC ;FOREACH THING
JRST TRYUP ;NO
SKIPL PNT,(SBITS2) ;GET SEMANTICS FOR THIS
ERR <DRYROT AT TRAGO -- MISSING SEM FOR FOREACH>
SKIPN SIMPSW
JRST TGI ;GO SET UP FOR BEXIT
TLZE FF,FFTEMP ;SIMPLE PROC, CHECK GOING IN
POPJ P,
LPCALL (FRELS) ;RELEASE THE SO AND SO
JRST LGOUP ;GO ON UP
DOBLK:
SKIPL PNT,(SBITS2) ;GET SEM
JRST NXPRSU ;NONE
MOVE TBITS,$VAL(PNT)
TDNN TBITS,[XWD SBSCRP,SET] ;ALLOCATIONS?
JRST LGOUP ;NO
TGI: TLZE FF,FFTEMP ;GOING IN?
POPJ P, ;LOSE
MRKUP: SKIPN BK ;IF FIRST BACK,SAY SO
MOVEM PNT,BK ;THIS IS THE FIRST
AOS BL ;INCR COUNT
LGOUP: SOJE B,XBKS ;IF UP, GO PUT OUT BEXIT
TRYUP: CAMN C,%NPDEC ;PROC?
JRST JOOPR ;YES, GO JUMP OUT
NXPRSU: SOS SBITS2
SOJA TBITS2,TOK
JOOPR: TLZE FF,FFTEMP ;
POPJ P, ;OK
PUSHJ P,XBKS ;GET OUT OF CURRENT BLOCKS
;; #MY# (1 OF 2) RHT BE SURE PD SEMBLK WILL APPLY
SKIPN PNT,PNT2 ;PICK UP PDA SEMBK
ERR <YOU CANNOT DO THIS GO TO>,1 ;
;; #MY# (1 OF 2) -- USED TO BE A SIMPLE MOVE PNT,PNT2
EMIT (<HRRZI LPSA,NOUSAC!JSFIX>) ;HRRZI LPSA,PDA_OF_LABEL
;;#MY# ↓ (2 OOF 2) RHT ALSO FIX A TYPO IN NEXT LINE
LDB C,[POINT LLFLDL,SBITS,=35] ;PICK UP LEX LEV OF LABEL
MOVSS C ;FOR EMITER
EMIT <HRLI LPSA,NOUSAC!USADDR!NORLC> ;HRLI LPSA,LL
XCALL <STKUWD> ;CALL THE STACK UNWINDER
POPJ P, ;ALL DONE
XBKS: SKIPN B,BK ;ANY TO EXIT
POPJ P, ;NO
HLLZ C,$SBITS(B)
HRR C,PCNT
HRLM C,$SBITS(B)
EMIT <HRRZI LPSA,NOUSAC!USADDR>
SOSG B,BL
JRST BEXCL
HRLZI C,(B)
EMIT <HRLI LPSA,NOUSAC!NORLC!USADDR> ; IF NEED, LOAD A COUNT
BEXCL: XCALL <BEXIT> ;EXIT THE BLOCK
POPJ P,
BEND LABEL
SUBTTL Case Statement Generators.
COMMENT ⊗CASSTR, CASEMT, CASEND, CASE1, ... -- Case Statement Generators⊗
BEGIN CASE
DSCR CASSTR, CASEMT, CASEND, CASE1, etc.
PRO CASSTR CASEM1 CASEMT CASEN1 CASEND CASE1 CASE2 CASE3
DES EXECS for generating case statement code. The expression
generated is compared to the numcode. The generated code:
1. compares index into the statements to number of statements.
2. calls an error routine (run-time) if something is fishy.
3. does an indexed jrst to dispatch to the right statement.
The syntactic contexts are:
CASE E OF → CASEX CASSTR
CASEX S ; → CASEX CASEMT
CASEX [ E ] S ; → CASEX CASEM1
CASEX S END → S CASEMT CASEND
CASEX [ E ] S END → S CASEM1 CASEN1
CASEX ( → CASEE CASE1 ;EXPRESSION CASE STATEMENT
CASEE E , → CASEE CASE2 ; "
CASEE E ) → E CASE2, CASE3
⊗
COMMENT ⊗ The CASE SEMBLK has the following form:
%TLINK -- saved version of CASTAK (from prev level)
$PNAME,+1 -- standard
$TBITS -- standard in CASE expression
$SBITS -- level as usual
$ADR (both halves), $ACNO (lh) used for fixups
$VAL -- lowest case # seen,,highest seen
$VAL2 -- 0 if no S's seen, >0 if old style, <0 if new style
⊗
↑CASSTR: ;START OF CASE CONDITIONS
GETSEM (1) ;SEMANTICS OF THE EXPRESSION.
MOVE PNT2,PNT ;MAKE SURE BOTH ARE VALID
PUSHJ P,BOLSTO ;STORE ALL BUT INDEX
GENMOV (GET,INSIST!INDX!POSIT,INTEGR)
MOVE A,[SKIPL NOUSAC]
PUSHJ P,EMITER
PUSHJ P,REMOP ;ALL DONE.
GETBLK <GENRIG> ;FOR CASE STATEMENT TEMPORARIES.
MOVEW (<%TLINK(LPSA)>,CASTAK);SAVE OLD CASTAK
SETZM CASTAK ;AND START A NEW ONE
MOVE A,PCNT
HRLM A,$ADR(LPSA) ;FIXUP FOR THE COMPARE, WHICH FOLLOWS.
MOVE A,[CAIL NOADDR]
PUSHJ P,EMITER
XCALL <CSERR>
MOVE A,[JRST @USX+NOADDR+NOUSAC]
MOVSS D
PUSHJ P,EMITER
QPUSH (CASTAK,PCNT) ;SAVE ON GENERALIZED STACK THE STATEMENT
POPJ P,
↑CASE1: GETSEM (1) ;CASEX SEMANTICS.
PUSHJ P,GETAC ;RESERVE AN ACCUMULATOR.
MOVEM D,$ACNO(PNT) ;REMEMBER IT.
MOVEM PNT,GENRIG
POPJ P,
↑CASE2: MOVEM B,THISE
SOJL B,.+3
JUMPN B,LPCS2 ;..LEAP..
PUSHJ P,LEVBOL ;.....
MOVE SP,GENLEF+2 ;CASEE SEMANTICS.
MOVE D,$ACNO(SP) ;RESERVED AC.
GETSEM (1) ;THE EXPRESSION.
SKIPN B,$TBITS(SP) ;TYPE FOR THE EXPRESSION.
HRRZ B,TBITS
MOVEM B,$TBITS(SP) ;NOW IT HAS SOME IF NOT BEFORE.
HRRI FF,INSIST!REM ;FOR GENMOV -- REMOP SO ALLSTO WON'T SEE IT.
TRNE B,STRING ;SPECIAL FOR A STRING.
JRST [GENMOV (STACK)
MOVNI A,2
ADDM A,SDEPTH ;FIX UP THE STACK
JRST CAS22]
TRO FF,SPAC!POSIT
GENMOV (GET)
CAS22:
JRST CASEMT
;EMIT JRST TO END OF CASE STATEMENT
; CASE N OF BEGIN [E]S; [E]S; ... [E] S END;
↑CASEM1: GETSEM (5) ;SEMANTICS OF CASEX
SKIPLE TEMP,$VAL2(PNT);LEGAL TO EXPLICITLY NUMBER?
ERR <TOO LATE TO START NUMBERING CASES>,1 ;NO
JUMPL TEMP,NOTFST ;NOT FIRST
HRROS $VAL(PNT) ;SMALLEST SEEN IS VERY LARGE
SETOM $VAL2(PNT) ;LEGAL TO EXPLICITLY NUMBER
NOTFST: GETSM2 (3) ;SEMANTICS OF `E'
TLNN TBITS2,CNST ;MUST BE CONSTANT
ERR <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
;;#FV# DCS 2-6-72 (1-1) CASE N OF BEGIN ["A"] DIDN'T WORK
GENMOV (CONV,EXCHIN!INSIST!EXCHOUT,INTEGR);A REASONABLE CONST.
;;#FV# (1-1)
SKIPGE TBITS2,$VAL(PNT2);NON-NEGATIVE?
ERR <CASE NUMBER MUST BE NON-NEGATIVE INTEGER CONSTANT>,1
QPOP (CASTAK) ;GET →1ST WD PREV STATEMENT
HRL A,TBITS2 ;CASE #
QPUSH (CASTAK) ;NOW CORRECT ENTRY
JRST CASSDO ;CONTINUE
;CASE N OF BEGIN S; S; S; S; ... S END;
↑CASEMT:GETSEM (2)
SKIPGE $VAL2(PNT) ;LEGAL TO IMPLICITLY NUMBER?
ERR <EXPLICIT CASE NUMBER REQUIRED>,1
HRRZM PNT,$VAL2(PNT) ;GT 0 MEANS IMPLICIT NUMBERING
AOS TBITS2,$VAL(PNT);NUMBER SEEN
CASSDO: PUSHJ P,ALLSTO ;STORE ALL
MOVE A,[JRST NOUSAC+JSFIX]
PUSHJ P,EMITER
HLRZ TEMP,$VAL(PNT);LOWEST SEEN YET
CAMGE TBITS2,TEMP ;THIS ONE LOWER?
HRLM TBITS2,$VAL(PNT);YES, THEN NO
HRRZ TEMP,$VAL(PNT)
CAMLE TBITS2,TEMP ;SAME FOR UPPER
HRRM TBITS2,$VAL(PNT)
HRL TBITS2,PCNT ;GET CURRENT PC
MOVS A,TBITS2 ;XWD CASE #, PC
QPUSH (CASTAK) ;SAVE
POPJ P,
↑CASE3: SOSL B,THISE ;THE TYPE OF EXPRESSION.
JRST [JUMPN B,LPCS3
PUSHJ P,LEVBOL
JRST .+1]
MOVE PNT,GENLEF+2 ;CASEE
MOVE D,$ACNO(PNT) ;RESERVED AC.
GENMOV (MARK,GETD) ;MAKE A TEMP (TBITS IS MAGICALLY SET UP
MOVEM PNT,GENRIG ;MARK THE EXPRESSION.
MOVEI A,2
TRNE TBITS,STRING
ADDM A,SDEPTH ;UNDO THE DAMAGE
;FALL THROUGH TO EMIT JRSTS.
↑CASEND:GETSEM (2) ;CASEX SEMANTICS
JRST CASENS
↑CASEN1: GETSEM (5) ;CASEX SEMANTICS.
CASENS: HRRZ B,$VAL(PNT) ;COUNT OF STATEMENTS.
SKIPG $VAL2(PNT) ;RANDOM NUMBERING?
ADDI B,1 ;YES, BE COMPATIBLE (CAIL)
MOVE TBITS2,PCNT ;CURRENT PC
ADDI TBITS2,(B) ; + # STATEMENTS IS OUT ADDR
HLL B,$ADR(PNT) ;FIXUP FOR THE CAIL
PUSHJ P,FIXOUT ;DO NOT RELOCATE THE FIXUP.
ADD B,[XWD 2,0]
HRR B,PCNT
PUSHJ P,FBOUT ;FIXUP FOR INDEXED JRST.
HRRZS $VAL(PNT) ;XWD 0,LAST STMT
SKIPL $VAL2(PNT) ;RANDOM NUMBERING?
SOS $VAL(PNT) ; NO, ONE TOO BIG
MOVEI LPSA,CASTAK ;SET FOR QSTACK OPS
TDZA C,C ;C←0, ALWAYS QBEG ONCE
CELUP: SKIPGE $VAL2(PNT) ;EXPLICIT NUMBERING
PUSHJ P,BBEG ; YES, ALWAYS START AT HEAD
JUMPE B,CLD ;NO QSTACK
CAMLE C,$VAL(PNT) ;DONE?
JRST CLD ; YES
CEILUP: HRRZ A,TBITS2 ;IN CASE NO SUCH ENTRY
PUSHJ P,QTAK ;GET NEXT
JRST RNDM ; NO SUCH NUMBER, USE OUT ADDR
HLRZ TEMP,A ;CASE # THIS STATEMENT
CAME C,TEMP ;THERE YET?
JRST CEILUP ; NOPE
HRRZS A ;YEP, THIS ADDR
RNDM: TLO FF,RELOC
PUSHJ P,CODOUT ;WRITE DISPATCH ADDR
AOJA C,CELUP ;GET NEXT
CLD: QFLUSH (CASTAK) ;DELETE STACK
MOVEW (CASTAK,<%TLINK(PNT)>);RESTORE OLD ONE
HRR B,PCNT ;FIXUP OUT JUMPS
HRL B,$ADR(PNT)
MOVE LPSA,PNT
PUSHJ P,URGSTR ;IF CASE STATEMENT, NAMED
FREBLK (PNT)
JRST FBOUT ;AND RELEASE CASEX SEMBLK
BEND CASE
SUBTTL Procedure Declarations.
BEGIN PROCED
COMMENT ⊗PROCEDURE Structure Descriptions, Data Declarations⊗
DSCR PRDEC -- name and type known, prepare for proc
PRO PRDEC
DES
PD0: PDEC @I ( → PDEC EXEC PRDEC CLRSET SCAN ¬DS1
PDEC @I ; → PDEC EXEC PRDEC ENDDEC SCAN ¬DS1
Procedure declaration. This routine has three parts:
1. Save status -- Temp ring, TTOP, TPROC
2. Initialize status -- VARB, ADEPTH, SDEPTH, FORMFX stack, TPROC, TTOP.
Down a text level, set FF bits for parameter scan
3. Output necessary code for beginning of procedure (if not FORWRD).
An ENTER has already been done for the symbol (semantics in NEWSYM).
SEMBLK descriptions for procedure Semantics
%TLINK → 2d Semblk for proc ,,%TBUCK standard
$PNAME standard
$TBITS standard
$SBITS standard -- RTNDON on means a RETURN was seen in this proc
$ADR <note1> ,,<note2>
$ACNO <note3> ,,<note4>
%RVARB, %RSTR standard
2d Semblk
%TLINK -- → 1st formal Semblk ,,%STEMP → saved TTEMP list (%TBUCK)
%SAVET → old TTOP ,, → old TPROC ($PNAME)
$NPRMS # arith params+1 ,, # string params * 2 ($PNAME+1)
$BLKLP BLKLIM qstack dscriptr saved at PRDEC ($TBITS)
$SBITS <note5>
$VAL -1 if TOPLEV on at PRDEC
$VAL2 DDT level of this procedure
<note1> fixup chain of jumps past SUB/PUSH code in string exit sequences
(for non-recursive RETURNs which return non-temp Strings).
<note2> fixup until entry addr known (delayed to PRUP for recursive procs),
then addr of procedure entry sequence
<note3> address of first word of proecedure text (for finding text, adjusting AOS)
<note4> fixup chain of jumps to procedure exit sequence (incl SUB/PUSH for Str)
<note5> address of JRST around 1st procedure in nest
⊗
ZERODATA (PROCEDURE CODE VARIABLES)
;FTRPRM -- QSTACK Descriptor -- holds Semantics of actual
; parameters as they are developed for FORTRAN calls.
; These are QTAKed back off after the JSA is generated
↓FTRPRM: 0
;FORMFX -- formal fixups QSTACK Descriptor -- see TOTAL for
; definition, description
;MESFLG -- on in Procedure call code if call is a MESSAGE
; call
↓MESFLG: 0
;TBSAVE -- Temp cell used to save tbits during call to DYNAMAK(ADRINS);
;
↓TBSAVE: 0
;MPFLAG -- Flag to FTRADR to tell that we really want the type bits
;in the left half of the adcon
↑↑MPFLAG:0
LEP <
;MPQCNT - number of matching procedure params seen so far
↓MPQCNT: 0
;MPVARS - qstack of ? params seen thus far
↓MPVARS: 0
>;LEP
ENDDATA
COMMENT ⊗ PRDEC -- When Name is Seen⊗
; 1 -- SAVE STATUS
;;#GP# DCS 2-6-72 (3-4) CHECK FORWARD FORMALS AGAINST REAL ONES
↑PRDEC: SETOM OLDPRM ;NO SAVED FORMAL DECLS YET
MOVEI A,PROCED ;BITS FOR PROCEDURE
NOLEP <
IORM A,BITS
>;NOLEP
LEP <
IOR A,BITS
TRNE A,ITEM
TRC A,ITEM!ITMVAR ;ITEM PROCEDURES REALLY ITEMVAR PROCS
MOVEM A,BITS
>;LEP
PUSHJ P,ENTID ;ENTER THE SYMBOL
;;#GP# (3) ALSO SET UP OLDPRM IN ENTERS
MOVE PNT,TPROC ;PNT → CURRENT PROC SEMANTICS.
LEFT PNT,%TLINK,LPSERR ;LPSA → 2D TPROC BLOCK
HRR TEMP,TTEMP
HRRM TEMP,%STEMP(LPSA) ;SAVE CURRENT TEMP RING.
PUSH P,LPSA ;SAVE → 2D BLOCK OF SURROUNDING PROC
MOVE PNT2,NEWSYM ;NEW SYMBOL (PROCEDURE NAME)
LEFT PNT2,%TLINK,LPSERR ;LPSA → 2D BLOCK
HRL PNT,TTOP ;TTOP,TPROC SAVED HERE
MOVEM PNT,%SAVET(LPSA)
TLZE FF,TOPLEV ;NO LONGER AT TOP LEVEL,
SETOM $VAL(LPSA) ; BUT SAVE PREVIOUS STATUS
MOVEW (<$BLKLP(LPSA)>,BLKIDX) ;SAVE CURRENT BLKIDX
SETZM BLKIDX ;CLEAR NEW ONE
AOS TEMP,NMLVL ;UPDATE DDT LEVEL
SETZM $SBITS(LPSA) ;JRST AROUND PROCS ADDR
HRRZM TEMP,$VAL2(LPSA)
; 2 -- INITIALIZE STATUS FOR THIS PROCEDURE
; ***** BUG TRAP
SKIPN ADEPTH ;THESE SHOULD BE ZERO HERE
SKIPE SDEPTH
ERR <DRYROT -- ADEPTH OR SDEPTH >,1
FOR II ⊂ (VARB,APARNO,SPARNO,ADEPTH,SDEPTH,TTEMP) <
SETZM II>
COMMENT ⊗
AT THIS POINT YOU MAY WANT TO SAVE OLD DISPLAY LIST
⊗
MOVE A,$SBITS(PNT2) ;NEED TO ZERO OUT THE DL FLD
TRZ A,DLFLDM ;ZERO IT
MOVEM A,$SBITS(PNT2) ;PUT IT BACK
SETOM RECSW ;ASSUME RECURSIVE -- IF WRONG WILL FIX BELOW
MOVE TBITS2,$TBITS(PNT2) ;BITS FOR THIS PROCEDURE
MOVEI A,0 ;ASSUME A RECURSIVE PROCEDURE
TLNN TBITS2,RECURS
MOVNI A,1 ;NON-RECURSIVE -- INDICATE NO FORMAL FIXUPS
XORM A,RECSW ;THIS WILL SET RECSW TO ALL 0 IF NOT RECSV
;; #MX# (1 OF 1) RHT CHECK FOR NON SIMP INSIDE SIMP
TLNN TBITS2,SIMPLE ;
SKIPN SIMPSW
JRST .+2
ERR <YOU HAVE DECLARED A NON-SIMPLE PROCEDURE INSIDE
A SIMPLE PROCEDURE. WE MAKE NO PROMISES... >,1
;; #MX#
SETOM SIMPSW ;ASSUME SIMPLE
TLNE TBITS2,SIMPLE ;IS IT REALLY
JRST GOTPD ;YES
SETZM SIMPSW ;NOT SIMPLE
;;#LQ# 2↓ RHT IF FWRD PROC HAD A PD, THEN KEEP IT
HRRZ LPSA,$VAL(PNT2) ;HAD A PD?
JUMPN LPSA,GOTPD ;DONT GET ANOTHER
;;#LQ#
GETBLK ;FOR PROC DESC STUFF
HRRM LPSA,$VAL(PNT2) ;RECORD IT
GOTPD:
QPUSH (FORMFX) ;SAVE MARKER
MOVEM PNT2,TPROC ;LET EVERYONE KNOW
MOVEM PNT2,TTOP ; WHO HAS A RIGHT TO KNOW WHERE
MOVEM PNT2,GENRIG ; THIS PROCEDURE IS
;5-12-72
; MOVEM PNT2,GENRIG+1 ; (COULD GO ONE OF TWO PLACES) NO MORE -- DCS
AOS LEVEL
PUSHJ P,MAKBUK ;DOWN A LEVEL
SKIPN SIMPSW ;IF NOT SIMPLE PROC
AOS CDLEV ;DOWN HERE TOO
TLO FF,NOCRFW!PRODEF ;SET DECLARATION BIT
; 3 -- ISSUE CODE
Comment ⊗ consider: ... X ← A+1;
BEGIN INTEGER PROCEDURE ... ⊗
TRNE TBITS2,FORWRD ;IF FORWARD DEC, IGNORE THE REST
JRST TMPOPJ ; (SOME OF ABOVE IS IRRELEVANT ALSO)
PUSHJ P,ZOTDIS
PUSHJ P,ALLSTO ;BECAUSE OF ABOVE CONSIDERATION
MOVE TEMP,CDLEV ;BUMP DISPLY LEVEL
MOVEI LPSA,RF
MOVEM LPSA,DISTAB(TEMP) ;F IS THE TOP DISPLAY
COMMENT ⊗ AT A LATER DATE MAY WANT TOO DO MORE --
I.E. BEFORE ALLSTO -- GO THRU ZZ CLEAR DISTAB SO
RECORD OF DISPLAYS GETS KEPT OVER PROC DECL;
⊗
;CREF THE NEW BLOCK NAME.
TLZ FF,NOCRFW
TLNN FF,CREFSW
JRST NOCRW ;NO
MOVEI A,15
PUSHJ P,CREFOUT
MOVE LPSA,PNT2
PUSHJ P,CREFASC
NOCRW:
HRRZ TEMP,PCNT ;ADDR OF JRST TO COME (IF ANY)
POP P,LPSA ;→2D SEMBLK FOR SURROUNDING PROCEDURE
SKIPE $SBITS(LPSA) ;HAS SOMEBODY ALREADY DONE THE JUMP?
JRST NOROUND ; YES, ONLY ONE JUMP AROUND PROCEDURES
; (SEE ENDDEC, ENDJMP, BUILT-IN ARRAY CODE)
HRRZM TEMP,$SBITS(LPSA);DENOTE JRST FROM HERE
EMIT (<JRST NOUSAC+NOADDR>) ;JRST AROUND PROC(S)
HRRZ TEMP,PCNT ;NOW NEW PCNT
NOROUND:HRLZM TEMP,$ACNO(PNT2);IDENTIFIES START OF PROCEDURE
TLNE TBITS2,RECURS
JRST RCSV ;RECURSIVE, CAN'T PLACE PROC YET
TLNN TBITS2,SIMPLE ;IS THIS NON-SIMPLE AND
TLNN TBITS2,INTRNL ;IS THIS AN INTERNAL PROCEDURE??
JRST NTINT ;NO
HRRZ PNT,$VAL(PNT2) ;LOOK AT PROCEDURE DESCRIPTOR
CAIN PNT,0 ;BETTER BE HERE
ERR <DRYROT -- DONT HAVE PD SEMBLK YET>
EMIT <JSFIX> ;PUT OUT PDA
NTINT: HRL B,$ADR(PNT2) ;CAN NOW GIVE PROCEDURE A HOME
HRR B,PCNT ;AT PCNT NO LESS!
HRRM B,$ADR(PNT2)
TLNE B,-1 ;IF IT WAS FORWARD, AND SOMEONE
PUSHJ P,FBOUT ;HAD THE FORSIGHT TO USE IT.
TRZ TBITS2,INPROG
MOVEM TBITS2,$TBITS(PNT2); NO LONGER FORWARD
SKIPE SIMPSW ;IF SIMPLE THEN ALL DONE
POPJ P,
PUSHJ P,MKSEMT ;PUT OUT MSCP
PUSHJ P,SETF ;MAKE IT ALL OFFICIAL
RCSV:
POPJ P,
↑↑TMPOPJ:POP P,TEMP
POPJ P,
COMMENT ⊗ ENDPR -- when params have been seen⊗
DSCR ENDPR
PRO ENDPR
DES
PD1: PDEC ; → PDEC EXEC ENDPR SCAN ¬S1
PDNO ; → NIL EXEC ENDPR SCAN ¬DS0
1. Turn off formal-scanning bit
2. Save parameter counts, insert stack displacements
for parameters
⊗
; 1
↑ENDPR: TLZ FF,NOCRFW!PRODEF
; 2
HRRZ PNT2,GENLEF+1 ;THIS PROCEDURE
LEP <
MOVE TEMP,$TBITS(PNT2) ;GET TYPE BITS
TLNN TEMP,MPBIND ;A MATCHING PROCEDURE?
JRST MATNOT ;NO
TLNE TEMP,SIMPLE ;BETTER NOT BE SIMPLE.
ERR <MATCHING PROCEDURES MAY NOT BE SIMPLE>,1
QPUSH (MPSTAK,PNT2) ;SEMANTICS OF MATCHING PROCEDURE
MATNOT:
>;LEP
HLRZ PNT2,%TLINK(PNT2) ;→SECOND BLOCK FOR THIS PROC
JUMPE PNT2,LPSERR ;HAS TO BE THERE
AOS A,APARNO ;SAVE COUNTS
HRLM A,$NPRMS(PNT2) ;SAVE COUNTS
MOVE A,SPARNO
LSH A,1 ; * 2 FOR STRINGS
HRRM A,$NPRMS(PNT2) ;AND SET UP A AND B WITH THEM
MOVEI A,1 ;LEAVE ROOM FOR RETURN ADDR
MOVEI B,1 ;LEAVE ROOM FOR SECOND STRING WORD
; NUMBER THE PARAMETERS, FIND BEGINNING OF THEIR LIST, REZERO VARB
SKIPN PNT,VARB ;ARE THERE ANY?
JRST PUTIN ; NO, MARK ZERO
PARD: PUSHJ P,GETAD ;FIND OUT ABOUT THIS FORMAL
TRNE TBITS,PROCED ;IF IT IS A PROCEDURE CALLED BY
TLNN TBITS,VALUE ; VALUE, COMPLAIN
SKIPA
ERR <DON'T PASS PROCEDURES BY VALUE>,1
TRNE TBITS,STRING ;STRING VALUE PARAMS ARE INDEXED
TLNN TBITS,VALUE ;FROM THE RSP STACK
JRST PST ;ALL OTHERS OFF OF RP
;;#HR# ALLOW STRING ITEMVAR PARAMETERS
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR]
;;#HR#
JRST PST
HRRM B,$ADR(PNT) ;DISPLACEMENT FROM TOP OF STACK
ADDI B,2 ;SIZE OF EACH PARAM
JRST PRLUP
PST: HRRM A,$ADR(PNT)
ADDI A,1
LEP < ;RECOPY SETS INTO STACK.
TRNE TBITS,SET
TDNE TBITS,[XWD REFRNC!SBSCRP,LPARRAY!ITEM!ITMVAR]
JRST NOSET ;EXCEPT THESE.
TRNE TBITS,FLOTNG ;DON'T LET CONTEXTS THROUGH
ERR <CONTEXTS MAY NOT BE PASSED BY VALUE>,1
; IF EXTERNAL (OR FORWARD) PROCEDURE, NO CODE GOES OUT (DCS -- 9/11/70)
; MORE FIXES 6-11-71
MOVE TEMP,GENLEF+1 ;PROC SEMANTICS
MOVE TEMP,$TBITS(TEMP)
TDNE TEMP,[XWD EXTRNL,FORWRD] ;SPECIAL DECLARATION?
JRST NOSET
; END BUG FIX (DCS -- 9/11/70) (6-11-71)
PUSH P,A
EMIT (<HRROI TAC1,NOUSAC>);CALL IT.
LPCALL (SETCOP) ;AND COPY IT.
POP P,A
NOSET:
TLNN TBITS,MPBIND ;A ?ITEMVAR
JRST NOMPRS ;NO.
MOVE TEMP,GENLEF+1 ;GET PROC'S SEMANTICS
MOVE TEMP,$TBITS(TEMP);
TDNE TEMP,[XWD EXTRNL,FORWRD]
JRST NOMPRS ;NO CODE FOR EXTERNS OF FORWARDS
TLNN TEMP,MPBIND ;THIS REALLY A MATCHING PROC.
ERR <? PARAMS ONLY LEGAL FOR MATCHING PROCEDURES>,1
PUSH P,A ;SAVE DISPLACEMENT
PUSH P,PNT ;SAVE
AOS MPQCNT ;WE HAVE ANOTHER ? PARAM
QPUSH (MPVARS,PNT) ;SAVE ? PARS SEMANTICS
;INITIALIZE ? PARAMS TO UNBOUND IF NECESSARY
MOVEI A,UNBND ;THE "UNBOUND" ITEM
PUSHJ P,CREINT ;GET CONSTANT SEMBLK
GENMOV (GET,0) ;
HRROS ACKTAB(D) ;PROTECT THAT AC
EXCH D,(P) ;SAVE AC # ITS IN
MOVE PNT,D ;THE PARAM SEMBLK
GENMOV (ACCESS,GETD) ;PROBABLY NOT NECESSARY
PUSHJ P,GETAN0 ;GET AN AC TO PLAY WITH
EMIT <MOVE ,0> ;LOAD PARAM
;NOTE GENMOV WILL NOT WORK HERE
;AS IT WOULD GENERATE MOVEI @
HRLM D,(P) ;TO USE AS INDX FOR MOVEM BELOW
HRLI C,20 ;THE INDIRECT BIT
EMIT <TLNE ,USADDR!NORLC> ;TEST FOR INDIRECT BIT
POP P,D ;AC CONTAINING "UNBOUND"
EMIT <MOVEM ,USX!NOADDR>
;; #LL# WAS UNPROTECTING WRONG AC
;; MOVSS D
HRRZS ACKTAB(D) ;"FREE" INDEX AC
POP P,A ;RESTORE DISPLACEMENT
NOMPRS:
>;LEP
PRLUP: LEFT PNT,%RVARB,PUTIN;NEXT ONE OR ZERO
MOVE PNT,LPSA ;PNT → NEXT ONE
JRST PARD
PUTIN:
LEP<
MOVE TEMP,GENLEF+1 ;GET PROC'S SEMANTICS
MOVE TEMP,$TBITS(TEMP)
;; #ME# FOLLOWING ONLY TESTED EXTRNL
TDNN TEMP,[EXTRNL,,FORWRD] ;IF EXTERNAL OR FORWARD DO NOTHING HERE
TLNN TEMP,MPBIND ;OR NOT MATCHING PROCEDURE
JRST PUTIN2 ;IGNORE
;; #NP# ↓ IF NO ? PARAMETERS DON'T EMIT THE ADDRESES
SKIPN B,MPQCNT
JRST PUTIN2
;; #NP#
PUSH P,PNT
HRR C,PCNT
ADDI C,2(B) ;
HRLI C,(C)
EMIT <JRST ,NOUSAC!USADDR> ;JRST AROUND ?TABLE
HRL PNT,PCNT ;SAVE ADDR OF TABLE
HRR PNT,LEVEL ;SAVE LEVEL FOR STKUWD
QPUSH (MPVSTK,PNT)
HRLI C,(B) ;NUMBER OF MP PARS
EMIT <,NOUSAC!USADDR!NORLC>;COUNT OF
LBPUTL:
QPOP (MPVARS,PNT)
HRRZ C,$ADR(PNT) ;THE STACK DISPLACEMENT
MOVNS C
SUBI C,1 ;FOR RETURN ADDRESS
HRL C,C
EMIT <,USADDR!NOUSAC!NORLC>
SOJG B,LBPUTL
POP P,PNT
SETZM MPQCNT ;FOR NEXT TIME
>;LEP
PUTIN2:
HRLM PNT,%TLINK(PNT2) ;PNT2→2D PROC BLOCK
SETZM VARB ;BRAND NEW PROC DECL COMING
;;#GP# DCS 2-6-72 (4-4) CHECK FORWARDS AGAINS NEW FORMALS
SKIPN LPSA,OLDPRM ;DID ANY FORWARD HAVE DECLRARATIONS?
JUMPE PNT,OKFORM ; NO, AND ALSO NO NEW DECLARATIONS
JUMPL LPSA,OKFORM ;NO PREVIOUS FORMALS, QUIT
SETOM OLDPRM ;CLEAR OUT, JUST FOR SAFETY
CKPRM: JUMPE LPSA,CHKRDN ;CHECK REAL DONE TOO
JUMPE PNT,TOOMF ;TOO MANY FORWARDS
PUSHJ P,URGSTR ;RELEASE FROM STRING RING
FREBLK () ;RELEASE STORAGE
MOVE TBITS,$TBITS(PNT)
CAME TBITS,$TBITS(LPSA);MUST BE SAME TYPE
ERR <FORMALS DON'T ALL AGREE WITH FORWARD DECLARATIONS>,1
HRRZ LPSA,%RVARB(LPSA);MOVE ON DOWN
HRRZ PNT,%RVARB(PNT)
JRST CKPRM
CHKRDN: JUMPE PNT,OKFORM ;MUST BOTH BE EMPTY
ERR <MORE FORMALS DECLARED THAN IN FORWARD DECLARATION>,1
OKFORM: POPJ P,
TOOMF: ERR <FEWER FORMALS DECLARED THAN IN FORWARD DECLARATION>,1
JRST KILLST ;REMOVE THE REST
;;#GP# (4)
COMMENT ⊗ PRUP -- When Procedure Body's Finished -- Entry, Exit, Fixups, etc.⊗
DSCR PRUP
PRO PRUP
RES
at S8: PDEC S ; → NIL EXEC PRUP SCAN ¬DS
1. Issues fixups for any jumps to procedure exit, and
for the jump around the procedure.
2. Issues procedure exit code, including stack adjusts
3. Issues procedure entry code if the procedure is recursive,
including a JRST to the procedure text.
4. Goes up a text level, restores VARB-type pointers
5. Allocates storage for locals to procedure (ALOT).
BITS used as special flag during PRUP (see NONULL+1)
⊗
↑PRUP: PUSHJ P,ALLSTO ;STORE ALLES NOT YET STORED
SETZM BITS ;NOT SPECIAL YET (BITS USED AS FLAG)
GETSM2 (2) ;PROCEDURE SEMANTICS
;;#HS# STRING ITEMVAR PROC TO BE TREATED AS ITEMVAR PROC. NOT STRING
TRNE TBITS2,ITEM!ITMVAR
TRZ TBITS2,STRING
;;#HS#
;⊗⊗ PNT2 set will almost continuously have Proc Semantics in the sequel
HRRZ PNT,$VAL(PNT2) ;PICK UP PD SEMBLK
MOVE TEMP,PCNT ;PICK UP PCNT
HRRM TEMP,$ACNO(PNT) ;
LEP <
TLNN TBITS2,MPBIND ;THIS A MATCHING PROC
JRST MPNO ;NO
QPOP (MPSTAK)
CAIE PNT2,(A) ;THE SAME?
ERR <DRYROT-PRUP MATCHING PROC>
EMIT <HRRZI LPSA,NOUSAC> ;ADDRESS OF PDA
;; #LK# BY JRL FOLLOWING WAS QPOP
QPOP (MPVSTK,C) ;THIS IS QPOP AGAIN, SINCE PEXIT NO LONGER
;REFERS TO IT
;; #LK#
EMIT <HRLI LPSA,NOUSAC!USADDR>;ADDRESS OF ?TAB
HRLI C,LPSA
EMIT <PUSH RP,NOUSAC!USADDR!NORLC> ;STACK PDA ADDRESS
XCALL (.FAIL) ;REPORT FAILURE
EMIT <SETZ 1,NOUSAC!NOADDR> ;FALLING THROUGH IS FALSE
PUSHJ P,EMITER ;BOTH NORMAL RETURN AND SKIP RETURN
MPNO:
>;LEP
PUSH P,TBITS2 ;REST WILL BE RECONSTRUCTED LATER
TRNE TBITS2,STRING ;IF NO RETURN MADE FROM STRING
TLNE SBITS2,RTNDON ; PROC, RETURN NULL HERE
JRST NONULL
SETZM PNAME
PUSHJ P,STRINS
GENMOV (STACK,REM) ;STACK IT AND FORGET IT
SETZM SDEPTH ;WE KNOW ABOUT STACK HERE
JRST NOEXIT ;BYPASS SPECIAL TEST (MUST HAVE SUB/PUSH CODE)
NONULL: HRLZ B,$ACNO(PNT2)
JUMPE B,[SETOM BITS ;NOBODY JUMPED TO SUB/PUSH CODE, BUT SOMEBODY
TLNE SBITS2,RTNDON ;RETURNED, SO SET SPEC (DON'T GENERATE
TRNN TBITS2,STRING ; SUB/PUSH) -- ONLY IF STRING PROC AND
SETZM BITS ; SOMEBODY RETURNED (TO EXIT2, ACTUALLY)
JRST NOEXIT]; NO FIXUP, IN ANY CASE
HRR B,PCNT ;EXIT TO HERE
PUSHJ P,FBOUT ; IF YOU CAN
Comment ⊗ Now call routine which obtains the necessary
counts and such (if the procedure is recursive). ⊗
NOEXIT:
TLZ FF,ALLOCT ; GET SIZES
PUSHJ P,ALOT
POP P,TBITS2 ;GET PROC TYPES BACK
TLNN TBITS2,RECURS ;RECURSIVE PROCEDURE?
JRST NOREC1 ; NO
; FIX UP ANY REFERENCES TO THE FORMALS OF THIS PROCEDURE
FFXLUP: QPOP (FORMFX) ;A→ [DISPL REL 0,ADDR OF INSTR]
JUMPL A,FFXERR ;MUST NOT BE NEGATIVE
JUMPLE A,PEXIT ;GO GENERATE EXIT CODE WHEN DONE
FFXERR: ERR <DRYROT -- FFXLUP>
NOREC1: SETZM ALOCALS ;DON'T INCLUDE IN STACK COUNTS
SETZM SLOCALS
QPOP (FORMFX) ;GET STACK POINTER OFF
JUMPGE A,FFXERR ;MUST BE NEGATIVE -- NO RECURSION
Comment ⊗ Generate procedure exit code -- local restore, subs, push str results ⊗
PEXIT: GETSM2 (2) ;PROCEDURE SEMANTICS AGAIN
;;#HS# IGNORE STRING BIT FOR STRING ITEMVAR PROC.
TRNE TBITS2,ITEM!ITMVAR
TRZ TBITS2,STRING
;;#HS#
LEFT PNT2,%TLINK,LPSERR;LPSA → SECOND BLOCK
PUSH P,$NPRMS(LPSA) ;NUMBERS OF PARAMS
;;#IP# RHT 7-18-72 RELEASE ANY VALUE SETS
;;#JK# RHT 10-3-72 (1 OF 3) ↓
TLZ FF,FFTEMP ;HAVENT RELEASED SETS YET
HLRZ PNT,%TBUCK(LPSA);POINT AT FIRST FORMAL
FRSV: JUMPE PNT,PEX2 ;ANY LEFT TO LOOK AT??
MOVE TBITS,$TBITS(PNT)
TRNE TBITS,ITEM!ITMVAR
JRST NXF
TLNE TBITS,VALUE ;IF ¬VALUE
TRNN TBITS,SET ;OR NOT SET THEN
JRST NXF ;GO ON TO NEXT
EMIT <HRROI TEMP,NOUSAC> ;CODE TO RELEASE THE SET
;; #JK# BY JRL 10-3-72 SAVE AC 1 OVER LEAP CALL
TRNE TBITS2,ALTYPS≠<PROCED+FORTRAN+STRING> ;WAS THIS A TYPED PROCEDURE
TLOE FF,FFTEMP ;DO WE HAVE TO SAVE AC1??
JRST STRCLX ;ALREADY DONE IT
HRLI C,A ;WILL SAVE AC 1 OVER LPCALL
EMIT <PUSH RP,NOUSAC!USADDR!NORLC>
STRCLX: LPCALL (SETRCL) ;
;; #JK#
NXF: HRRZ PNT,%RVARB(PNT) ;ON TO NEXT
JRST FRSV
PEX2:
;;#JK# RHT 13-3-72 3 OF 3
HRLI C,A ;RESTORE AC1 IF NEED
MOVE A,[POP RP,NOUSAC!USADDR!NORLC] ;
TLNE FF,FFTEMP ;DID WE SAVE IT
PUSHJ P,EMITER ;PUT IT BACK
;;#JK#
;;#IP#
SKIPGE BITS ;SPECIAL?
JRST DNTPSH ; YES, NO NEED SUBS OR PUSHES (DONE BFORE RETURN)
MOVE PNT,SLIMS ;VBL DESCRIPTOR BOUNDARIES
MOVE A,SSDIS ;STRING STACK DISPL
MOVEI D,RSP ;INDICATE USE OF SP STACK
;⊗ PNT is Sem of last,,Sem of 1st; A is # str locs, RH(P) is #str params
PUSHJ P,RESTOR ;ADJUST THE STACK, RESTORE LOCALS
; NOW PUSH RESULT INTO CORRECT STACK LOC IF NECESSARY
TRNE TBITS2,STRING ;STRING PROCEDURE WHICH REQUIRED A SUB?
CAIG B,2 ; (SET BY RESTOR, NUMBER SUBTRACTED)
JRST DNTPSH ; NO, NOT STRING OR RESULT IN RIGHT PLACE
HRLI C,-1(B) ;RELATIVE LOCATION OF RESULT TO CURRENT SP
EMIT <PUSH RSP,USADDR!NOUSAC!NORLC(RSP)>;#SUB'ED -1(SP)
EMIT <PUSH RSP,USADDR!NOUSAC!NORLC(RSP)>;#SUB'ED -1(SP)
; NOW ISSUE FIXUP FOR JUMPS AROUND ABOVE SUB/PUSH CODE
DNTPSH: SETZM BITS ;DON'T LEAVE BITS SCREWED UP
HLLZ B,$ADR(PNT2) ;THAT SPECIAL FIXUP
JUMPE B,NO2XIT ;NOBODY RETURNED NON-TEMP RESULT
HRR B,PCNT ;ISSUE FIXUP
PUSHJ P,FBOUT ;DOESN'T HAPPEN IN RECURSIVE PROCEDURES
NO2XIT:
SKIPE SIMPSW ;IF SIMPLE
JRST DOOUT ;NO NEED TO MANGLE F
MOVEI C,0 ;
EMIT (<MOVE RF,USADDR!NOUSAC!NORLC(RF)>); RESET RF
DOOUT: MOVSS (P) ;WANT NO ARITH PARAMS
MOVEI D,RP ;WANT RP
MOVE A,ASDIS ;ARTIH STACK DISPL
SKIPN SIMPSW ;ONLY HAVE FOR NON SIMPLE
ADDI A,1 ;SINCE (F) TAKES UP A WORD
HRRZ TEMP,(P) ;NOW CONSIDER THE CASE WHERE THERE
ADDI TEMP,-1(A) ; ARE NO LOCALS OR PARAMETERS
TRNN TEMP,-1 ;
JRST [EMIT (<POPJ RP,NOUSAC+NOADDR>) ;(ONLY A RETURN
JRST PENTRY] ;ADDRESS) -- DO POPJ
MOVE PNT,ALIMS ;PNT, A, D, (P) SET UP ANALAGOUS TO ABOVE CALL
PUSHJ P,RESTOR ;RESTORE THE P SIDE
HRLZ C,(P) ;NUMBER OF ARITH PARAMS.
HRLI D,RP ;USE THIS STACK AS INDEX
EMIT (<JRST USADDR+INDRCT+NORLC+USX+NOUSAC+JSFIX>);JRST @PARAMS(RP)
; NOW PRODUCE PROCEDURE ENTRY CODE IF RECURSIVE PROCEDURE
PENTRY: POP P,TEMP ;THROW THE #PARAMS PAIR AWAY
TLNN TBITS2,RECURS ;
JRST PRUPYU ;NOT RECURSIVE
TRZN TBITS2,INPROG ;NO LONGER FORWARD
; ***** BUG TRAP
ERR <DRYROT -- PENTRY>
HRRM TBITS2,$TBITS(PNT2) ;OFF IN MEMORY
;NOW, IF INTERNAL, PUT OUT PDA WORD
TLNN TBITS2,INTRNL ;IS THIS AN INTERNAL PROCEDURE??
JRST NOIN.1 ;NO
HRRZ PNT,$VAL(PNT2) ;LOOK AT PROCEDURE DESCRIPTOR
CAIN PNT,0 ;BETTER BE HERE
ERR <DRYROT -- DONT HAVE PD SEMBLK YET>
EMIT <JSFIX> ;PUT OUT PDA
;NOW THE PDA WORD IS OUT, IF NEED BE
NOIN.1: HRLZ B,$ADR(PNT2) ;FIXUP FOR EARLY JUMPS
HRR B,PCNT
HRRM B,$ADR(PNT2) ;THIS IS PROCEDURE ADDRESS
TLNE B,-1 ;DID ANYONE CALL EARLY?
PUSHJ P,FBOUT ;ADDR,,FIXUP FOR EARLY CALLS
PUSHJ P,MKSEMT ;MARK THE STACK
MOVEI D,RP ;DO ARITH SAVES
MOVE A,ASDIS ;STACK DISPL
SUBI A,2 ;FOR MSCP
CAILE A,0 ;IF ANY ARITH LOCALS
PUSHJ P,SAVIT ;ZERO THE APPROPRIATE STUFF
MOVEI D,RSP ;STRING STACK
SKIPE A,SSDIS ;IF STRING LOCALS, BLT THEM TOO
PUSHJ P,SAVIT
PUSHJ P,SETF ;MAKE IT OFFICIAL
HLL C,$ACNO(PNT2) ;TEXT ADDR (OF AOS IF THERE IS ONE)
EMIT (<JRST NOUSAC+USADDR>)
PRUPYU:
TLO FF,ALLOCT ;***** ASSUME SAVES ACS
PUSHJ P,ALOT ;ALLOCATE THE STORAGE
GETSEM (2) ;PROC SEMANTICS BACK
PUSHJ P,LNKMAK ;PUT OUT STRING LINK BLOCK IF NECESSARY
Comment ⊗ Now fix some syntactic things (restore counts,
pointers, etc.), go up a level, and quit . ⊗
SYNTUP: LEFT PNT,%TLINK,LPSERR
HRRZM PNT,VARB ;CAN ADD ON FROM HERE
SKIPE $VAL(LPSA) ;RETURNING TO TOP LEVEL?
TLO FF,TOPLEV ; YES, RESET BIT
MOVEW (BLKIDX,<$BLKLP(LPSA)>) ;RESTORE OLD BLKIDX
MOVE TEMP,%SAVET(LPSA)
HRRZM TEMP,TPROC ;RESTORE VARB STRUCTURE POINTERS
HLRZM TEMP,TTOP
MOVE A,$TBITS(TEMP) ;PICK UP TYPE BITS OF PROC
;;#KB# RHT ↓ 1 OF 2 (11-11-72) MUST SAVE LPSA
PUSH P,LPSA ;SAVE THE LIFE OF MY AC
PUSHJ P,ZOTDIS
;;#KB# 2 OF 2 ↓
POP P,LPSA ;CRIED THHE DESPARATE PROGRAMMER
SKIPE SIMPSW ;
SKIPA TEMP,CDLEV
SOS TEMP,CDLEV ;
HRLI TEMP,RF ;PUT RF BACK RIGHT
HLRZM TEMP,DISTAB(TEMP);
SETZM RECSW ;ASSUME DADDY NOT RECURSIVE
TLNE A,RECURS ;UNLESS HE WAS
SETOM RECSW ;THEN SAY SO
SETZM SIMPSW ;RESTORE SIMPLE PROCEDURE FLAG
TLNE A,SIMPLE
SETOM SIMPSW ;SAY IT IS SIMPLE
HRRZ TEMP,TPROC ;GET IT BACK FOR THE NEXT LOAD
HLRZ A,%TLINK(TEMP) ;RIGHT TEMP,%TLINK,
JUMPE A,LPSERR ; LPSERR
MOVE TEMP,%STEMP(A) ;GET PARTIAL CORE TEMP LIST BACK
HRRZM TEMP,TTEMP ;RESTORE TO RIGHTFUL POSITION
SOS NMLVL ;REDUCE DDT LEVEL
SOS LEVEL ;UP A LEVEL
PUSHJ P,CLRSET ;CLEAR OUT BITS
TLNN FF,CREFSW ;IF CREFFING, PUT OUT SYMBOLS FOR FORMALS.
JRST FREBUK ;RELEASE OLD BUCKET, RETURN
HLRZ LPSA,%TBUCK(LPSA) ; TO FIRST FORMAL.
CRFNO: JUMPE LPSA,FREBUK ;ALL DONE.
PUSHJ P,CREFDEF ;SYMBOL DEFINITION.
HRRZ LPSA,%RVARB(LPSA)
JRST CRFNO
Comment ⊗ FORWRD declarations come here to undo damage
at PD1: PDNO ; → NIL EXEC FWUNDO SCAN ¬DS0
⊗
↑FWUNDO:
QPOP (FORMFX) ;GET STACK MARKER OFF
; ***** BUG TRAP
SKIPLE A ;MUST NOT HAVE PUT ANYTHING ON
ERR <DRYROT -- FWUNDO>
GETSEM (1)
JRST SYNTUP ;UP A LEVEL, RESET LIST POINTERS, ETC.
COMMENT ⊗ RESTOR, SAVIT,MKESMT,SETF -- Subroutines for Above
PAR (P)rh = #PARAMS (size of params)
A = #LOCALS (size of)
PNT = SEMANTICS OF LAST,,SEMANTICS OF FIRST TO BE RESTORED
RES B=# words subtracted
DES Sub sum of both from stack ref'ed in D if there are any (incl Str res in SUB)
BLT from 1+paramsize(stack) to first local, ending at last local, if recursive ⊗
RESTOR: PUSH P,PNT ;SAVE POINTERS
PUSH P,A ;SAVE # LOCALS
MOVEI B,0 ;IN CASE NONE SUBTRACTED
ADD A,-3(P) ;TOTAL TO SUBTRACT
HRLS A ;XWD
JUMPE A,RESDUN ;NOTHING TO DO AT ALL
ADD A,X22 ;IF STRING PROCEDURE WITH ANY LOCALS OR PARAMS,
CAIN D,RSP ; AND ADJUSTING STRING STACK, SUBTRACT AN EXTRA
TRNN TBITS2,STRING
SUB A,X22 ; TWO WORDS TO ACCOUNT FOR STRING RESULT
PUSHJ P,CREINT
HRRZ B,$VAL(PNT) ;TOTAL NUMBER SUBTRACTED
MOVE A,[SUB] ;RESULTS TO PNT -- SOME OF THESE
PUSHJ P,EMITER ;EMITS SHOULD EVENTUALLY BE COMBINED
RESDUN: POP P,A ;REMOVE #PARAMS WORD
POP P,PNT ;SAVED PNT
POPJ P,
Comment ⊗
IN: A -- #locals
D -- stack #
PNT -- end,start semantics
⊗
SAVIT:
PUSH P,PNT
PUSH P,A
MOVEI A,0 ;CREATE A ZERO
PUSHJ P,CREINT ;GET A ZERO
EMIT (<PUSH >) ; PUSH IT ONTO STACK
SOSG A,(P) ;ONE LESS ZERO TO BLT
JRST PSH1.1 ;NOTHING LEFT TO DO
CAILE A,4 ;BLT CHEAPER ONLY IF >4 MORE
JRST BLTIT ;
PSH1: EMIT (<PUSH >) ;PUSH A ZIP ON
SOSLE (P) ;COUNT DOWN
JRST PSH1 ;GO PUSH ANOTHER
PSH1.1: POP P,A ;GET A BACK
POP P,PNT ;GET IT BACK
POPJ P, ;THATS ALL
BLTIT: ;WE WILL DO A BLT
HRL D,D ;NEED STACK NO AS INX
MOVEI C,0 ;ZERO DISPL
EMIT(<HRLI RTEMP,NOUSAC!NORLC!USADDR!USX>) ;FROM HERE
HRLI C,1 ;DISPL OF ONE
EMIT(<HRRI RTEMP,NOUSAC!NORLC!USADDR!USX>) ;TO THERE
;NOW FOR THE ADD
MOVE A,(P) ;GET THE COUNT INTO A
HRLS A ;XWD
PUSHJ P,CREINT
EMIT (ADD) ;ADD STK,[XWD SIZ,SIZ]
HRL C,D ;USE STACK # AS DISPL
EMIT (<SKIPL USADDR+NORLC+NOUSAC>) ;SKIPL STK
EMIT (<PDLOF NOADDR>) ;PDLOF STK,0
POP P,A ;RESTORE STACK
POP P,PNT ;GET THIS BACK -- NOT IMPORTANT
MOVEI C,0 ;ZERO DISPL
EMIT (<BLT RTEMP,NOUSAC!USADDR!NORLC!USX>);BLT RTEMP,(STK)
POPJ P,
COMMENT⊗
DSCR MKSEMT
DES EMITS CODE TO BUILD ONE FHQ MSCP
PARM PNT2 POINTS AT FIRST PROC SEMBLK
SID MANGLES A,B,C,D,PNT,LPSA,TEMP
⊗
MKSEMT: PUSH P,FF ;SAVE IT
HRLI C,RF
EMIT (<PUSH RP,NOUSAC!USADDR!NORLC>); PUSH P,F
MOVE B,CDLEV ;IF PARENT IS GLOBAL, NO LOOP
SOJG B,SLNKIT
HRRZ A,$VAL(PNT2) ;A→PD SEMBLK
HLRZ PNT,%TLINK(A) ;PNT→PDA SEMBLK
CAIE PNT,0 ;HAVE WE ONE?
JRST PPDAW ;YES
GETBLK ;NO--GET ONE
MOVE PNT,LPSA ;SET PNT TO THIS ONE
HRLM A,%TLINK(PNT) ;LNK BACK
HRLM PNT,%TLINK(A) ;AND FWD
PPDAW: EMIT (<PUSH RP,NOUSAC>) ;PUSH P,[PDA,0]
JRST MKSSS ;GO DO STRING STUFF
SLNKIT: PUSHJ P,GETAN0 ;GET AC FOR LOOP
HRLI C,RF
EMIT (<SKIPA, USADDR!NORLC>);SKIPA AC,F
HRL D,D ;USE AS INDEX
HRLI C,1
EMIT (<MOVE USX!USADDR!NORLC>) ;MOVE AC,1(AC)
HRLI C,1
EMIT (<HLRZ RTEMP,NOUSAC!USX!USADDR!NORLC>); HRLZ TEMP,1(AC)
HLRZ PNT,%TLINK(PNT2) ;2ND PROC SEMBLK
HRRZ PNT,%SAVET(PNT) ;PARENT PROC
HRRZ PNT,$VAL(PNT) ;POINT AT PARENTS PD SEMBLK
EMIT (<CAIE RTEMP,NOUSAC!JSFIX>);
HRLZ C,PCNT
SUB C,[XWD 3,0]
EMIT (<JRST 0,NOUSAC!USADDR>);JRST .-3
HRRZ PNT,$VAL(PNT2) ;PNT2→PD SEMBLK
EMIT (<HRLI>) ;HRL AC,PDA
HRL C,D
EMIT (<PUSH RP,USADDR!NOUSAC!NORLC>);PUSH P,AC
COMMENT⊗
NOW THAT AC IS STATIC LINK, MIGHT AS WELL REMEMBER THAT FACT
⊗
MOVE B,CDLEV ;INTERNAL LEVEL
SUBI B,1 ;DADDY
PUSHJ P,DISBLK ;LPSA→DISPLAY SEMBLK
HRRM D,DISTAB(B) ;UPDATE DISTAB
MKSSS: HRLI C,RSP
EMIT (<PUSH RP,USADDR!NORLC!NOUSAC>) ;PUSH P,SP
HRRZ PNT,$VAL(PNT2) ;MY PD SEMBLK
HRRZ A,PCNT ;PCNT AFTER MKSEMT
HRLM A,$ACNO(PNT) ;SAVED IN PD SEMBLK
POP P,FF
POPJ P,
COMMENT ⊗
DSCR SETF
DIS EMITS CODE TO SET UP NEW RF
PARM SAME AS MKSEMT
SID DITTO
⊗
SETF: PUSH P,FF
HRRI C,-2 ;WILL BE -2(P) FOR E PART
SKIPE RECSW ;UNLESS IT WAS RECURSIVE
MOVN C,ASDIS
HRLZ C,C ;FOR ADDRESS PART
EMIT (<HRRZI RF,NOUSAC!NORLC!USADDR(RP)>); HRRZI RF,-2(P)
POP P,FF
POPJ P,
COMMENT ⊗ TWPR1, TWPR2 -- Procedure Syntax Twiddlers⊗
DSCR TWPR1, TWPR2
PRO TWPR1, TWPR2
DES
at IDL: PDEC @IDL @I ) → PDEC EXEC INTID ENDDEC TWPR2 SCAN
¬PD1 # Q0
at PD0: PDEC @I ; → PDEC ; EXEC PRDEC TWPR1 ¬PD1 #Q0
⊗
↑TWPR2: MOVE PNT,GENRIG
MOVEI A,0 ;RESULTS TO PARRIG
JRST TWPR
↑TWPR1: MOVE PNT,GENRIG+1
MOVEI A,1
TWPR: PUSHJ P,GETAD
MOVE TEMP,%PDNO ;IF FORWARD, PARSER WILL LOOK FOR NO
TRNE TBITS,FORWRD ; PROCEDURE BODY
MOVEM TEMP,PARRIG(A) ;MODIFIED SYNTACTIC ENTRY
POPJ P,
SUBTTL Procedure Calls
COMMENT ⊗RDYCAL -- Prepare to Call Procedure⊗
DSCR RDYCAL
PRO RDYCAL
DES
@CALL SG → @CALL SG EXEC RDYCAL ¬
Prepare for a procedure call.
A block needs to be prepared to hold information about the
call, because PROC(a,PROC(b)) would otherwise
cause awful confusion. The block contains:
1. In %TLINK, → procedure semantics
2. In %TBUCK, →next formal parameter definition
3. In $ADR, initial Qstack pointer for FTRPRM.
4. In $VAL, SDEPTH,,0. These (the stack counts) will be restored after the call.
The reason that ADEPTH cannot be saved has to do with the way LEAP
stacks things one too late. In other words, when a fucntion call is
seen, the ADEPTH count is really one too low, and all hell will break
loose if the procedure caller merely restores things. So it must keep
explicit count of what has happened.
The preparation of this block constitutes preparation for
the procedure call.
⊗
↑RDYCAL:
GETBLK (GENRIG)
JRST RDYCL
↑RDYCL1:
GETBLK (GENRIG+1) ;LPSA → NEW BLOCK
RDYCL:
;; #LJ# ALL LEAP ARGS MUST REALLY BE STACKED BEFORE PROCEDURE CALL
LEP <
PUSH P,LPSA ;SAVE LPSA OVER OKSTACK
PUSHJ P,OKSTAC ;MAKE SURE EVERYTHING IS STACKED THAT SHOULD BE
POP P,LPSA ;RESTORE LPSA
>;LEP
GETSEM (1) ;PNT → SEMANTICS OF PROCEDURE
LEP <
TLNE FF,LPPROG ;FOREACH IN PROGRESS?
TLNN TBITS,MPBIND ;AND THIS A MATCHING PROCEDURE?
JRST NOMPRO
PUSH P,PNT ;SAVE IT
PUSH P,LPSA ;IT ALSO
PUSHJ P,CHKSAT ;POP SATISFIERS INTO CORE IF NECESSARY
MOVEI A,0
PUSHJ P,CREINT
GENMOV (STACK,0) ;RESERVE A PLACE FOR ITEM PARAM TO SPROUT
POP P,LPSA
POP P,PNT
NOMPRO:
>;LEP
GLOC <
SKIPN MESFLG ;IS THIS A MESSAGE PROCEDURE ?
JRST NOMESQ ;NOPE
SETZM MESFLG ;RESET THE FLAG.
TLO SBITS,LPFREE ;THIS IS HOW WE TELL EVERYONE.
TLNN TBITS,MESSAGE
ERR <MESSAGE: REQUIRES MESSAGE PROCEDURE>,1
MOVEM SBITS,$SBITS(PNT);
NOMESQ:
>;GLOC
MOVEM TBITS,$TBITS(LPSA)
MOVEM SBITS,$SBITS(LPSA) ;COPY THESE
HRLM PNT,%TLINK(LPSA)
EXCH PNT,LPSA
TLNE TBITS,OWN ;BUILT-IN FUNCTION?
JRST BLTN ; YES, GO SET UP BYTE POINTER
LEFT ,%TLINK,LPSERR ;SECOND BLOCK OF PROC
LEFT (,%TLINK) ;→FIRST PARAM OR NIL
HRRM LPSA,%TBUCK(PNT)
QCAL: QPUSH (FTRPRM) ;MAKE SURE STACK IS
QPOP (FTRPRM) ;INITIALIZED
MOVE TEMP,FTRPRM
MOVEM TEMP,$ADR(PNT) ;SAVE QSTACK POINTER
; lh of $VAL used to collect the number of string elements to be removed
; after the call -- rh is used for non-string elements.
;*-* HRLZ TEMP,SDEPTH
;*-* MOVEM TEMP,$VAL(PNT) ;SAVE SDEPTH,,0
GLOC <
TLNN SBITS,LPFREE ;IF A MESSAGE PROCEDURE, THEN
POPJ P, ;
XCALL <.MES1> ;PREPARE FOR THE CALLS.
>;GLOC
POPJ P,
BLTN: MOVEI TEMP,$SBITS+2(LPSA)
HRLI TEMP,440600 ;POINT 6,FIRST PARAM WORD
MOVEM TEMP,$VAL2(PNT) ;STORE FOR PARAM DESCRIPTOR RETRIEVAL
JRST QCAL ;FINISH UP
GLOC <
;MESSAGE PROCEDURE STARTER.
↑MESCL: SETOM MESFLG ;NEXT FCALL IS A MESSAGE.
POPJ P,
>;GLOC
COMMENT ⊗ Describe CALARG⊗
DSCR CALARG
PRO CALARG
DES
at SID: IPR SG → S SG EXEC ISUCL1 ¬S9
at EE2: PCALL @E ) → S EXEC CALARG ISUCAL SCAN ¬S9
FCALL @E ) → P EXEC CALARG ISUCAL TYPPRO SCAN ¬XID
@CALL @E , → @CALL EXEC CALARG ¬EX0
IPR SG → P SG EXEC ISUCL1 TYPR1 ¬XID
Generate parameter calls, issue procedure calls
A. Parameter calls
Several things have to happen here:
1. REFERENCE or VALUE determines whether an address or a
value will be "PUSH"ed. For reference parameters,
certain things are illegal (i.e. expressions, procedure
executions) unless we are issuing a FORTRAN call. Procedures
with no parameters must be called unless the formal is a
(reference, non-FORTRAN) procedure. The address word (with
types) is created (if possible) for reference
parameters. A reference parameter called by reference is a special
case.
2. A destination must be determined. For FORTRAN calls, the
semantics of the created (address) word is pushed into
a compile time "buffer" Qstack. For others, the
thing is stacked appropriately on the P or SP stack
(code is issued).
⊗
COMMENT ⊗ CALARG -- Pass a Parameter⊗
TOOMNY: ERR <TOO MANY ARGUMENTS SPECIFIED TO PROCEDURE>,1
;;#GW# 5-11-72 DCS (1-4) AVOID CALLING AT RUNTIME WITH TOO MANY PARAMS
TLNN TBITS,CONOK ;TRYING TO CALL AT COMPILE TIME?
JRST SAMADR ;NO
TLO TBITS,400000 ;SOMETHING SILLY -- DON'T DO IT.
MOVEM TBITS,(SP) ;UPDATE
JRST SAMADR
;;#GW# (1-4)
↑CALARG: PUSH P,SP ;GOOD SAFE AC
PUSH P,ADEPTH ;THIS IS FOR COMPARING PURPOSES.... SEE BELOW
GETSEM (2) ;SEMANTICS OF PROCEDURE CALL BLOCK
MOVE SP,PNT ;SAVE HERE
TLNE TBITS,ANYTYP ;IF ON, ASSUME REFERENCE, TYPE OK
JRST SAMADR
TLNE TBITS,OWN ;BUILT-IN PROCEDURE?
JRST [ILDB TBITS2,$VAL2(PNT) ; YES, GET FORMAL DESCRIPTION
JUMPE TBITS2,TOOMNY ; TOO MANY ARGUMENTS SUPPLIED
TRZ TBITS2,40 ; TURN OFF DEFAULTABLE BIT
MOVE TBITS2,BLTTBL(TBITS2)
JRST BLTBAK ;CONTINUE AFTER SIMILAR BRANCH
]
HRRZ PNT2,%TLINK(SP) ;PNT2 → NEXT FORMAL PARAM DESCR
JUMPE PNT2,[TRNN TBITS,FORTRAN ;FORTRAN CALL?
JRST TOOMNY ;NO -- TO MANY ARGS CITED.
SETOM TBITS2 ;FLAG AS DON'T CONVERT
JRST FTRARG] ;ELSE GO AWAY.
HRRZ LPSA,%RVARB(PNT2) ;→NEXT FORMAL PARAM AFTER THIS
HRRM LPSA,%TBUCK(SP) ;STORE POINTER TO NEXT IN CALL BLOCK
MOVE TBITS2,$TBITS(PNT2) ;ALL THAT'S IMPORTANT
BLTBAK: TRNE TBITS,FORTRAN ;FORTRAN CALL?
JRST FTRARG ; YES
GETSEM (1) ;SEMANTICS OF ACTUAL TO PNT GROUP
TLNE TBITS2,REFRNC ;BY REFERENCE?
JRST REFARG ; YOU BETCHUM
LEP <
TLNE TBITS2,MPBIND ;A FORMAL ? ITEMVAR
JRST MPPARM ;YES
>;LEP
; ***** BUG TRAP
TLNN TBITS2,VALUE ;TEST UNLIKELY CASE
ERR <DRYROT -- CALARG>,1
; VALUE PARAMETER
TLNN SBITS,LPFRCH!FREEBD
JRST VALPAR
TLNE SBITS,LPFREE
ERR <UNBOUND LOCAL AS PARAMETER TO PROCEDURE>,1
PUSHJ P,CHKSAT ;POP SATISFIERS INTO CORE IF NECESARY
VALPAR: TLNE TBITS,SBSCRP ;MAKE A TEST
ERR <ARRAYS BY VALUE NOT IN>,1
PUSH P,TBITS2 ;SAVE FORMAL TYPE BITS
TRNE TBITS,PROCED ;IF VALUE PROCEDURE, NO PARAMS,
PUSHJ P,CALNPR ; CALL IT NOW
OKPRM: POP P,B ;TYPE OF FORMAL
LEP <
TLNN TBITS,FORMAL!SBSCRP ;FOR LEAPISH CONSTRUCTS.
TRNN TBITS,ITEM
JRST GMV
TRNN B,ITEM!ITMVAR ;TARGET TYPE
ERR <ITEM TYPE MISMATCH>,1 ;BLOW
SKIPE PNT,$VAL2(PNT) ;PLACE WHERE ITEM NUMBER IS STORED.
PUSHJ P,GETAD ;AND GET HIS BITS.
HRRI FF,POSIT
JRST GMV2+1
GMV: TRNE TBITS,ITEM!ITMVAR
JRST GMV2
TRNE TBITS,LSTBIT
JRST [TRNN B,LSTBIT ;BOTH LISTS, NO WORRY
ERR <WARNING-LIST EXPR. COERCED TO SET EXPR>,1
JRST .+1]
>;LEP
GMV2:
HRRI FF,INSIST!POSIT
;;# # DCS 2-29-72 CALL F(CONST,...) AT COMPILE TIME
MOVE TBITS2,$TBITS(SP) ;PROC CALL BLOCK BITS
TLNE TBITS2,CONOK ;STILL OK?
TLNN TBITS,CNST ; ALSO NO USE IF THIS NOT CONST
JRST STRET ;NO
GENMOV (CONV) ;MAKE SURE CONVERTED
HRRI FF,0 ;IN CASE NOT CONST
TLNN TBITS,CNST ;CONST OF RIGHT TYPE?
JRST STRET ;NO
; STILL CONOK, SAVE CONST
QPUSH (FTRPRM,PNT) ;SAVE THE SEMBLK
POP P,ADEPTH ;NO CHANGE TODAY
POP P,SP ;GET STACK BACK
POPJ P, ;DONE RIGHT NOW
;;# #
STRET: PUSHJ P,CONCHK ;STACK PREV CONSTS
GENMOV (STACK) ;DO THE PUSH.
MOVEI PNT,0 ;SO WON'T REMOP TWICE
MOVSI TEMP,2 ;Keep track of the number of string
;;#HM# JRL 5-31-72 AVOID DRYROT BY STRING ARGS TO MESSAGE PROCEDURE
MOVE SBITS,$SBITS(SP) ;WILL TELL IF A MESSAGE PROC. CALL
;;#HR# JRL 6-14-72 A STRING ITEM IS NOT A STRING
TRNE TBITS,ITEM!ITMVAR ;TURN OFF STRING BIT FOR ITEMS
TRZ TBITS,STRING
;;#HR#
TRNE TBITS,STRING ; words which will adjust SDEPTH
TLNE SBITS,LPFREE ;A MESSAGE PROCEDURE
JRST CALRET ;If message pro, or not string no sdepth change
ADDM TEMP,$VAL(SP) ; when call is finished.
;; #HM#
JRST CALRET ;DONE ALREADY
CONCHK: PUSH P,B
;; #MA (1 OF 4) ↓ SAVE FF OVER CALL
PUSH P,FF
MOVE TEMP,$TBITS(SP) ;CONOK bit on in this Semblk (PCALL
TLZN TEMP,CONOK ; block) if calling runtime which can
;; #MA (2 OF 4) ↓
JRST FBPOPJ ; be evaled at comp. time, and all prev
MOVEM TEMP,$TBITS(SP) ; args were const -- but this arg is
MOVE B,$ADR(SP) ; non-const, so must recover.
CAMN B,FTRPRM ;If there were no previous constant
;; #MA (3 OF 4) ↓
JRST FBPOPJ ; args, there is nothing left to do.
PUSH P,PNT ;Now issue stack code for each arg
CONCAL: QTAKE (FTRPRM) ; previously saved (types already
JRST CONDUN ; matched up before saving).
MOVE PNT,A
GENMOV (STACK,GETD!REM)
MOVSI TEMP,2 ;Update the ADEPTH or SDEPTH count in
TRNN TBITS,STRING ; Pcall Semblk -- will be used to readjust
AOSA $VAL(SP) ; these variables when call finished.
ADDM TEMP,$VAL(SP)
JRST CONCAL
CONDUN: MOVE TEMP,$ADR(SP) ;No REF args were handled, our part of
MOVEM TEMP,FTRPRM ; this stack had only consts, can remove.
POP P,PNT ;Now the state of things is as if the
PUSHJ P,GETAD ; stack code had gone out the first time.
;; #MA (4 OF 4) ↓ RESTORE FF
FBPOPJ: POP P,FF
BPOPJ: POP P,B
POPJ P,
MPPARM: ;BINDING ITEMVAR PARAMETER
LEP <
TRNN TBITS,ITEM!ITMVAR ;BETTER BE ITEM TYPE
ERR <PARM TO ? ITEMVAR NOT ITEM EXPRESSION>,1
TLNE PNT,FBIND!QBIND ;IS IT BIND ITEMVAR?
JRST PASREF ;WILL PASS BY REFERENCE
TLNE SBITS,LPFRCH!FREEBD
TLNN SBITS,LPFREE ;STILL FREE WITHIN FOREACH?
JRST VALPAR ;NO TREAT AS VALUE PARAMETER
NTPARM: QPUSH (MPQSTK,PNT) ;PUT THIS ON PARM LIST
; AT THIS POINT GENERATE APPROPRIATE LPCALL FOR POTUNB IF NECESSARY.
TLNE TBITS,FREEBD
JRST [MOVE PNT,$VAL2(PNT) ;GET LOCAL NUMBER
GENMOV (STACK,0)
LPCALL (STKQPR) ;INTERPRETIVE CALL TO SEE IF BOUND
JRST CALRET]
PASREF: PUSH P,PNT ;SAV LH ACTUALLY
GENMOV (INCOR,0) ;MAKE SURE NOT IN AC
HRLI PNT,20 ;WANT INDIRECT BIT
SETOM MPFLAG ;TO TELL THAT WE WANT TYPE BITS
PUSHJ P,FTRADR ;GET ADCON
GENMOV (STACK,0) ;STACK IT
SETZM MPFLAG
POP P,PNT
TLNN PNT,QBIND
JRST CALRET
HRLZI D,RP ;WILL NOW LOAD VAL FROM STACK
EMIT <MOVEI TAC1,INDRCT!NOUSAC!NOADDR!USX> ; GEN MOVEI TAC1,@(P)
HRLI C,UNBND ;FOR COMPARE WITH UNBOUND
EMIT <CAIE TAC1,NOUSAC!USADDR!NORLC>
EMIT <MOVEM TAC1,NOUSAC!NOADDR!USX>
JRST CALRET
>;LEP
; FORTRAN ARGUMENT -- ASSURE VALID TYPE
FTRARG:
GETSEM (1)
TLNE TBITS,SBSCRP
ERR <DON'T PASS ARRAYS TO FORTRAN (YET)>,1
TRNE TBITS,PROCED ;PROCEDURES MUST BE EVALUATED
PUSHJ P,CALNPR ; CALL WITH NO PARAMS
HRRI FF,INSIST!POSIT
SKIPG B,TBITS2 ;THIS IS THE TYPE WE HOPE FOR
TRC FF,INSIST!ARITH ;NO TYPE SPECIFIED -- JUST GET ARITH.
TLNE TBITS,CNST ;PROTECT CONSTANTS BY MOVING THEM.
JRST CNGET
GENMOV (CONV)
JRST MAKADR ;GO MAKE ADDRESS CONSTANT
CNGET: TRO FF,MRK
GENMOV (GET)
JRST MAKADR
REFARG: PUSHJ P,CONCHK ;STACK PREV CONSTANTS
TRNE TBITS2,PROCED ;IF FORMAL ¬ PROCEDURE,
JRST CHKEXP
TRNE TBITS,PROCED ;AND ACTUAL IS ONE, ERROR
PUSHJ P,CALNPR ;MAKE IT AN EXPRESSION TO PASS BY REFERENCE
CHKEXP:
; #HZ# JRL 6-27-72 TEST SBSCRP BIT BEFORE ALL OTHERS
TLNE TBITS,SBSCRP
JRST CKTYP
LEP <
TRNE TBITS,ITEM
ERR <DO NOT PASS ITEMS BY REFERENCE>,1
TRNE TBITS2,LSTBIT ;LIST FORMAL?
JRST [TRNE TBITS,LSTBIT; AN ACTUAL LIST?
JRST .+1 ;YES
MOVE B,SET!LSTBIT
JRST RTYPER]
TLNE SBITS,LPFRCH!FREEBD
ERR <FOREACH LOCAL AS REFERENCE PARAMETER>,1
>;LEP
; #HZ#
TLNN SBITS,ARTEMP!STTEMP ;EXPRESSION?
JRST CKTYP ;NO
TLNE SBITS,FIXARR ;FIXED CALCULATED ARRAY THING?
JRST CKTYP ; YES, DON'T WORRY
TLNN SBITS,INDXED ;OK IF CALCULATED SUBSCRIPT
JRST [TRNN TBITS2,STRING ;DON'T ALLOW STRING EXP BY REF
ERR <WARNING: EXPRESSION BY REFERENCE;
WILL WORK BUT INACCESSABLE AFTER CALL>,1
STREXP: TRNE TBITS2,STRING
ERR <NO STRING EXPRESSIONS BY REFERENCE>,1
GENMOV (INCOR)
QPUSH (FTRPRM,PNT) ;SAVE FOR LATER REMOPING
JRST .+1] ;GO CHECK TYPES
CKTYP:
TRNA TBITS,PROCED ;SPECIAL CHECK
JRST [PUSH P,TBITS2
HRRZ TEMP,GENLEF+1 ;GET THE ARGUMENT PROCEDURE
TLNE TBITS,OWN
JRST CKTYPO ;EVEN SPECIALER
CKTYP0: HRRZ TEMP,%RVARB(TEMP) ;GET PARMS TO PARM PROC
JUMPE TEMP,CKTYP2 ;DONE
HRRZ TBITS2,$TBITS(TEMP) ;GET BITS
TLNN TBITS2,REFRNC ;PARMS OF PRAM PROC MUST BE REF.
ERR <PARAMETERS TO A PROCEDURE ARGUMENT TO A PROCEDURE MUST BE REFERENCE>,1
JRST CKTYP0
CKTYPO: MOVEI TEMP,$ACNO(TEMP) ;MAKING BYTE POINTER
HRLI TEMP,440600 ;POINT 6,FIRST PARM WORD
CKTYP1: ILDB TBITS2,TEMP ;GET BITS
;;#??# RHT WHAT IS GOING ON HERE?????
JUMPE TBITS,CKTYP2 ;DONE
TLNN TBITS,REFRNC ;
ERR <PARAMETERS TO A PROCEDURE ARGUMENT TO A PROCEDURE MUST BE REFERENCE>,1
JRST CKTYP1
CKTYP2: POP P,TBITS2
JRST .+1 ]
MOVE B,TBITS ;ALGORITHM IS TO MAKE SURE THAT ALL BITS
AND B,[XWD SBSCRP,ALTYPS] ;ON IN ACTUAL ARE ON IN FORMAL.
SETCM TEMP,TBITS2 ;THIS ALLOWS ARRINFO AND FRIENDS TO HAVE
TLNE TBITS2,SBSCRP ;IF FORMAL REQUIRES ARRAY, THEN MAKE SURE IT IS
TLNE TBITS,SBSCRP
TDNE B,TEMP ;ANY TYPE ARRAYS PASSED TO THEM.
RTYPER: JRST [TERPRI <WARNING: TYPE MISMATCH FOR REFERENCE CALL>
TERPRI <CONVERTED EXPRESSION WILL BE PASSED BY REFERENCE>
ERR <ORIGINAL VARIABLE WILL NOT BE ALTERED BY PROCEDURE>,1
MOVE B,TBITS2
GENMOV (CONV,INSIST) ;MAKE TYPE CONVERSION
MOVE TBITS2,TBITS ;DON'T LET IT HAPPEN AGAIN!
JRST STREXP]
JRST MAKADR ;FINISH UP
; CREATE FORTRAN-LIKE TYPE BITS FOR AC FIELD
SAMADR: GETSEM (1) ;NOBODY ELSE GOT ACTUAL'S SEMANTICS
MAKADR: MOVE TBITS2,$TBITS(SP) ;GET PROC BITS BACK
TLNE SBITS,INDXED ;NO NEED TO STORE INDXED THINGS
JRST LATER ; BECAUSE DYNAMAK AND FRIENDS WILL
GENMOV (INCOR) ;MAKE SURE ARG IS IN CORE.
LATER:
TRNE TBITS2,FORTRAN ;IF HERE AND FORTRAN, WE DEFINITELY
JRST .+3 ;WANT TO STAY HERE DAMMMMMIT
TLNE TBITS,REFRNC
JRST REFREF ;REF CALLED BY REF (SPCL CASE)
MOVEI TEMP,0 ;COLLECT BITS HERE
TRNE TBITS,FLOTNG ;0 FOR INTEGR, 2 FOR FLOATING,
ADDI TEMP,2
TLNE TBITS,SBSCRP ;8 + OTHERS FOR ARRAYS
ADDI TEMP,=8
LSH TEMP,5 ;TO AC POSITION
HRL PNT,TEMP ;TO AC AREA
; PNT NOW CONTAINS SEMANTICS OF REF VBL IN LH, TYPES IN RH
TRNE TBITS2,FORTRAN ;CALLING FORTRAN?
JRST FTRSAV ;YES, JUST SAVE ADCON SEMANTICS
TLNN TBITS,SBSCRP ;STACK VBL ITSELF IF SBSCRP
PUSHJ P,ADRINS ;GET → ADCON IN PNT, ETC.
GENMOV (STACK,0) ;STACK IT
JRST CALRET
FTRSAV: PUSHJ P,FTRADR ;GET (UNIQUE) ADCON SEMANTICS
QPUSH (FTRPRM,PNT) ;SAVE SEMANTICS TILL LATER
JUMPL PNT,[POP P,A ↔ POP P,SP
POPJ P,]
JRST CALRET
REFREF: GENMOV (STACK,ADDR) ;JUST STACK IT AGAIN (REF BY REF)
CALRET:
MOVE SP,GENLEF+2 ;SINCE TOTAL USES THE DAMNED THING.
POP P,A ;OLD ADEPTH.
GLOC <
MOVE SBITS,$SBITS(SP) ;SBITS FOR PROCEDURE.
TLNN SBITS,LPFREE ;IF A MESSAGE PROCEDURE IS BEING ISSUED.
JRST CAL00 ;NO
MOVE TBITS2,$TBITS(PNT2) ;DESTROYED IF A REFERENCE.
TRNE TBITS2,PROCED!LABEL ;THESE NOT ALLOWED.
ERR <MESSAGE: INVALID PARAMETER LIST MEMBER>,1
TRNE TBITS2,STRING ;GODDAMN
TLNE TBITS2,REFRNC
JRST .+3 ;FIGURE OUT WHICH STACK TO SUBTRACT
SOS SDEPTH
SOSA SDEPTH
SOS ADEPTH ;ALL OVER.
HRL C,TBITS2 ;GET THE TBITS WORD IN TAC1
EMIT (<MOVEI TAC1,USADDR!NOUSAC!NORLC>)
HLL C,TBITS2
EMIT (<HRLI TAC1,USADDR!NOUSAC!NORLC>)
XCALL <.MES2> ;AND PROCESS THE PARAM.
JRST NOADJ ;DO NOT INDEX COUNTS. -- OTHERWISE DOOM.
CAL00:
>;GLOC
CAME A,ADEPTH ;SAME AS NOW (WAS THERE A PUSH DONE??)
AOS $VAL(SP) ;NO -- UPDATE COUNTS.
NOADJ: POP P,SP ;RESTORE STACK
JRST REMOP ;REMOVE TEMP ARGS,RETURN
↑CALNPR: PUSH P,GENRIG ;SINCE ISUCL1 DESTROYS IT.
MOVEM PNT,GENLEF+1 ;SIMULATE A CALL TO RDYCAL
PUSHJ P,RDYCL1 ;AS THE PARSER WOULD DO IT
MOVEW GENLEF+1,GENRIG+1 ;RESULTS BACK TO LEFT SIDE
PUSHJ P,ISUCL1 ;CALL THE PROCEDURE
MOVE PNT,GENRIG+1
POP P,GENRIG ;RESTORE THE BLESSED CELL (IT ONLY POINTS TO PROC).
JRST GETAD ;LEAVE ITS SEMANTICS IN PNT, ETC.
COMMENT ⊗ ADRINS -- Subrt for Above -- Prepare an Address Constant (Semblk)
Address constant blocks have fixup information for
address constants necessary for procedure calls. The
constants are of the form:
TYP(fortran),,address, where TYP is:
0 for integer
2 for floating
8 + others for arrays
An ADCON block uses %RVARB to link to the ADRTAB ring.
The %TLINK field indicates the intity whose AD
is being CONned. The type is inserted in the left
half of $ADR -- fixups for the ADCON go in $ADR(rh).
These constants will be output after space is
allocated for the associated variables, or at the
time of a FORTRAN call. For temps and those
blocks involved in a FORTRAN call, unique ADCON
blocks are assigned for each eventual word of code. For
others, fixups are chained via a search of the
ADCON list.
IN: PNT -- TYPE,,semantics of entry
OUT: PNT,TBITS,SBITS -- semantics of result
C(lh) -- old fixup
Call ADRINS for normal insertion, FTRADR for unicke ones
If FTRADR is called with MPFLAG non-zero the type bits,
in left half PNT will be inserted but otherwise FORTRAN-like
things won't happen (see DYNAMAK)
If MPFLAG is set the address of the array is considered to be
the address of the cell containing the descriptor. I don't
believe ADRINS is every called with an array except if MPFLAG
is set.
⊗
↑ADRINS: TLOA FF,FFTEMP ;CONDUCT A SEARCH
↑FTRADR: TLZ FF,FFTEMP ;DON'T
PUSHJ P,GETAD ;GET SEMANTICS OF AD TO BE CONNED
TRNE SBITS,DLFLDM ;IF A DISPLAY REG IS NEEDED
JRST DYNAMAK ;MUST DO DYNAMAK
;; #KD# ↓ RHT 11-13-72 FOLLOWING INSTR HAD SBITS MISSING
TLNE SBITS,CORTMP ;ALSO CHECK THE CASE OF TEMPS IN REC PRO
SKIPN RECSW ;
JRST .+2 ;
JRST DYNAMAK ;
TRNE TBITS,PNTVAR ;DON'T REALLY UNDERSTAND THESE YET
ERR <POINTER VARS MAY NOT BE CALLED BY REFERENCE>,1
TLNE SBITS,FIXARR ;IF HAVE CALCULATED WHOLE INDEX THING,
JRST DYNAMAK ; GET IT WITH A MOVEI
TLNN TBITS,FORMAL ;IF ARG IS NOT IN FIXED LOC,
TLNE SBITS,INDXED
JRST DYNAMAK ; CREATE ADCON AT RUN TIME
TLNN FF,FFTEMP ;ALSO IF FORTRAN TYPE ADCON
JRST INSNEW ;JUST INSERT A NEW ONE
TLNE SBITS,ARTEMP ;DON'T SEARCH FOR TEMP MATCHES
JRST TEMLUK ; IN THE SAME WAY
TLNE TBITS,CNST ;ALSO CONSTANTS DONE DIFFERENTLY
JRST CONADD
SRCH: MOVE LPSA,ADRTAB ;ADDRESS CONSTANT "RING"
JUMPE LPSA,INSNEW ;NOTHING YET, MAKE SOMETHING
SRCLUP: HLRZ TEMP,%TLINK(LPSA) ;→SEMANTICS OF THING
CAIN TEMP,(PNT) ;SAME STUFF?
JRST FOUND1 ;YES, FOUND ONE
LEFT ,%RVARB,INSNEW ;KEEP LOOKING
JRST SRCLUP
TEMLUK: TLNN SBITS,CORTMP ;MUST BE A CORTMP
ERR <DRYROT -- TEMLUK>
MOVE LPSA,ADRTAB ;SEARCH ADCON TABLE FOR SAME ID NO
JUMPE LPSA,INSNEW ;NONE FOR THIS TEMP YET
MOVE A,$PNAME(PNT) ;TEMP ID NO FOR THIS TEMP
TMLUUP: MOVE TEMP,$SBITS(LPSA)
TLNN TEMP,ARTEMP ;MUST BE TEMP OR DON'T LOOK
JRST LEFLUK
CAMN A,$PNAME(LPSA) ;SAME TEMP?
JRST GETADL ;YES, THIS IS THE RESULT
LEFLUK: LEFT ,%RVARB,INSNEW ;LOOP UNLESS YOU RUN OUT
JRST TMLUUP
FOUND1: HLLZ TEMP,$ADR(LPSA) ;MAKE SURE TYPE HASN'T CHANGED
HLR TEMP,PNT
TSC TEMP,TEMP ;SEE IF TYPE FROM ADCON IS SAME
SKIPN TEMP ; AS THAT COMING IN
JRST GETADL ;IT IS,DONE
INSNEW: GETBLK
;GET ANOTHER ONE
PUSHJ P,RNGADR ;ADD THIS ADCON TO ADRTAB
HLLM PNT,$ADR(LPSA) ;STORE TYPE
HRLM PNT,%TLINK(LPSA) ;AND SEMANTICS OF THING BEING ADCONNED
MOVEW (<$PNAME(LPSA)>,<$PNAME(PNT)>) ;TRANSFER ID NO IF ANY
MOVEI TEMP,INTEGR ;TYPE FOR ADCON ITSELF, IF NEEDED
MOVEM TEMP,$TBITS(LPSA)
MOVEM SBITS,$SBITS(LPSA) ;SAVE SBITS FOR ADCON TYPE DETERMINATION
HRR PNT,LPSA ;DO NOT CLOBBER LEFT HALF OF PNT.
JRST GETAD ;THAT'S IT.
CONADD: TRNE TBITS,STRING ;WILLING TO PASS ALL BUT STRING CONST
ERR (<NO STRING CONSTANTS BY REFERENCE>,1) ;BY REFERENCE
PUSH P,$VAL(PNT) ;SAVE FOR A MOMENT
PUSH P,$TBITS(PNT)
PUSHJ P,REMOP ;IN CASE IN AC
POP P,BITS
POP P,A
PUSHJ P,ADCINS ;SPECIAL ENTRY (UNIQUE)
JRST INSNEW ;MAKE ADCON FOR THIS UNIQUE CONSTANT
DYNAMAK:
MOVEM TBITS,TBSAVE ;SAVE SBITS
TLNE TBITS,SBSCRP ;AN ARRAY
TLZN TBITS,REFRNC ;TURN OFF REFERENCE BIT
CAIA
TLO TBITS,VALUE ;TURN ON VALUE BIT IF WAS REFRNC
MOVEM TBITS,$TBITS(PNT);
GENMOV (GET,ADDR!REM) ;WILL GET ADDRESS OF THING WITH A MOVEI
;IT ALL HAPPENS MAGICALLY
MOVE TBITS,TBSAVE
MOVEM TBITS,$TBITS(PNT)
HLLZ C,PNT ;TYPE BITS, USE AS ADDR FLD OF HRLI
PUSHJ P,MARKINT ;MARK AN INTEGER FOR KICKS.
TLNE FF,FFTEMP ;FORTRAN CALL REQUIRE THIS ADCON?
POPJ P, ;NO, LEAVE SEMANTICS FOR PUSH
JUMPN C,NDBITS ;ARE THERE NON-ZERO TYPE BITS
SKIPE MPFLAG ;IF NO BITS AND NOT FORTRAN
POPJ P, ;RETURN
NDBITS: SKIPN MPFLAG ;DON'T CHANGE INSTR IF REMEMBER PARAM
OR C,[JUMP] ;FORTRAN WANTS A NOOP HERE
EMIT (<HRLI USADDR+NORLC>) ;HRLI AC,TYPE*2↑5
SKIPE MPFLAG
POPJ P, ;IF REMEMBER OF MP RETURN NOW.
PUSHJ P,REMOP ;DON'T NEED SEMANTICS ANYMORE
HRRO PNT,PCNT ;FIXUP ADDR IN RH, MARK LH NEG TO DIFFERENTIATE
EMIT (<MOVEM NOADDR>) ;MOVEM AC,FIXED UP LATER
POPJ P,
COMMENT ⊗ ISUCAL -- Call the Procedure, Mark Resultant Type, etc.⊗
DSCR ISUCAL, ISUCL1
PRO ISUCAL ISUCL1
RES
PCALL @E ) → S EXEC CALARG ISUCAL SCAN GO S9
FCALL @E ) → P EXEC CALARG ISUCAL TYPPRO SCAN GO XID
IPR SG → P SG EXEC ISUCL1 TYPR1 GO XID
⊗
↑ISUCAL:
SKIPA PNT,GENLEF+2 ;GET PROCEDURE
↑ISUCL1:
MOVE PNT,GENRIG+1 ; CALL BLOCK SEMANTICS
; (PLACED BY RDYCAL FOR ISUCL1)
ISSUE: PUSH P,$ADR(PNT) ;CONTAINS SAVED FTRPRM PTR.
PUSH P,$VAL(PNT) ;RESTORE DEPTHS
;BUT AFTER CALLING ALLSTO, ETC.
BICHK: MOVE TBITS2,$TBITS(PNT) ;NEED TO CHECK BUILT-IN
MOVE C,TBITS2 ;FOR CONST EVAL DON'T DO IT FLAG
TLNE TBITS2,OWN ; IS IT?
JRST [MOVE B,$VAL2(PNT) ;YES, GET NEXT PARAM DSCRPTR
ILDB TEMP,$VAL2(PNT) ; SO CAN RESTORE
JUMPE TEMP,OKCAL ;SHOULD BE 0 (NONE LEFT)
TRZN TEMP,40 ;DEFAULTABLE?
JRST ERCAL ;NO
MOVE TBITS,BLTTBL(TEMP);TBITS OF THIS ARG
TLNN TBITS,VALUE ;REF NEVER DEFAULTED
JRST ERCAL
PUSH P,PNT ;SAVE PNT
MOVEI A,0 ;COMMON NULL VALUE
TRNE TBITS,ITMVAR ;ITEMVARS ARE SET TO NEC
MOVEI A,UNBND ; THE UNBOUND ITEM
TRNE TBITS,STRING ; A STRING GETS A NULL STRING
JRST NSTVP ;
PUSHJ P,CREINT ;
SFFPRM: MOVE TEMP,PNT ;
MOVE PNT,(P) ;THE PROCID
MOVEM B,$VAL2(PNT)
JRST PCA1 ;GO PUSH THE CONST ARG
NSTVP: PUSH P,BITS ;SAVE SOME CRUFT
PUSH SP,PNAME ;
PUSH SP,PNAME+1 ;
SETZM PNAME ;NULL
PUSHJ P,STRINS ;MAKE ONE
POP SP,PNAME+1 ;
POP SP,PNAME ;PUT EM BACK
POP P,BITS ;
JRST SFFPRM ;GO STACK IT
]
RIGHT PNT,%TBUCK,OKCAL ;MAKE SURE FORMAL LIST IS EMPTY
HRRZ TEMP,$VAL2(LPSA) ;GET DEFAULT VALUE , IF ANY
JUMPE TEMP,ERCAL ;YOU LOSE
PCA: PUSH P,PNT ;SAVE
PCA1: PUSH P,GENLEF+1 ;
PUSH P,GENLEF+2 ;
MOVEM TEMP,GENLEF+1 ;
MOVEM PNT,GENLEF+2 ;
PUSHJ P,CALARG ;OH, WHAT A DREADFUL THING TO DO
POP P,GENLEF+2 ;
POP P,GENLEF+1 ;
POP P,PNT ;PUT EM BACK THE WAY THEY WAS
;;#NH# RHT 7-25-73 1 OF 1 THE THINGS ON THE STACK WERE CHANGED BY CALARG
SUB P,X22
JRST ISSUE ;TRY AGAIN
;;#NH#
ERCAL: ERR <NOT ENOUGH PARAMETERS SUPPLIED TO PROCEDURE>,1
;;#GW#↓ 5-11-72 DCS (2-4) DON'T CALL AT COMPTIME IF WRONG NUMB. OF PARAMS
TLO C,400000 ;FLAG ERROR -- DON'T EVAL AT COMPILE TIME
OKCAL: HRRZ LPSA,PNT ;RELEASE CALL BLOCK,
HLRZ PNT,%TLINK(PNT) ; GET SEMANTICS OF PROC
FREBLK
PUSHJ P,GETAD ; PNT, ETC. DESCRIBE PROC SEMANTICS
;;# # DCS 2-29-72 COMPILE-TIME CALL OF PROCEDURE
TLNN TBITS2,CONOK ;If CONOK on, all args were const, we call
JRST NC ; the procedure now, recording approp. const.
POP P,TEMP ;Any saved Depths are irrelevant now
EXCH SP,STPSAV ;Prepare stacks and pdlov-message information
MOVSS POVTAB+6 ; for the impending call.
MOVE B,(P) ;Fetch start of our part of stack, verify that
CAMN B,FTRPRM ; there were args, or quit.
JRST NA
NOWLUP: QTAKE (FTRPRM) ;Actually stack each constant value, then REMOP
JRST NA ; its representation. Choose the right stack.
MOVE PNT2,A
PUSHJ P,REMOP2
MOVE TBITS2,$TBITS(PNT2)
;;#GW#↓ 5-11-72 DCS (3-4) SEE JUST ABOVE
JUMPL C,NOWLUP ;DON'T DO IT IF MARKED
TRNE TBITS2,STRING
JRST NOWSTR
PUSH P,$VAL(PNT2)
JRST NOWLUP
NOWSTR: PUSH SP,$PNAME(PNT2)
PUSH SP,$PNAME+1(PNT2)
JRST NOWLUP
NA: HLRZ TEMP,$ADR(PNT) ;Get the address of the procedure from its
;;#GW#2↓ 5-11-72 DCS (4-4) SEE JUST ABOVE
JUMPL C,NS
PUSHJ P,(TEMP) ; Semblk, and call it for its value
;;#GW#↓ SEE JUST ABOVE
MOVEM 1,SCNVAL ;Store resultant value where CONINS will expect
TRNN TBITS,STRING ; it, along with the desired type bits from
JRST NS ; the procedure's type.
HRRZ TEMP,-1(SP) ;Align Strings to full-word boundary by
JUMPE TEMP,NLS ; concatenating 0 (if non-null)
PUSH SP,[1]
PUSH SP,[POINT 7,[0]]
PUSHJ P,CAT
SOS -1(SP) ; then remove the extra character from the end
NLS: POP SP,PNAME+1
POP SP,PNAME
NS: EXCH SP,STPSAV ;PUT OLD STACKS BACK
MOVSS POVTAB+6
ANDI TBITS,-1≠<PROCED!FORWRD!INPROG>
TLO TBITS,CNST
MOVEM TBITS,BITS
PUSHJ P,CONINS
POP P,FTRPRM ;Back the Qstack up to value at start of call
JRST MRKDN ;This just records the result
;;# #
NC:
GLOC <
TLZN SBITS,LPFREE ;A MESSAGE PROCEDURE ??
JRST CAL01 ;NO
MOVEM SBITS,$SBITS(PNT)
HRROI B,$PNAME+1(PNT) ;PRINT NAME.
POP B,PNAME+1
POP B,PNAME ;AND READY TO
PUSHJ P,STRINS ;MAKE A CONSTANT.
PUSHJ P,GETAD ;GET BITS.
GENMOV (STACK,0) ;PISS ON IT.
SOS SDEPTH
SOS SDEPTH ;SINCE TYPPRO WILL ADD 2 TO SDEPTH
MOVEI TBITS2,STRING ;CROCK -- THIS IS THE TYPE OF MESS.
;#IK#↓ 7-5-72 RHT PREVENT DL FLD OF SBITS FROM CAUSING MUCH BAD DISPLAY LOADING
MOVEI SBITS2,0 ;RENDER SBITS2 HARMLESS (FOR FUTURE EXCHIN &STACK)
JRST MRKCAL ;AND FINISH OUT
CAL01:
>;GLOC
PUSHJ P,STORIX ;INTERNALS.AND EXTERNALS ARE NOW STORED.
TRNE TBITS,FORTRAN ;IF FORTRAN CALL
JRST FTRCAL ;GO ISSUE IT.
MOVEI D,1 ;PREPARE TO STORE R1
TRNE TBITS,INTEGR!FLOTNG
PUSHJ P,STORZ ;DO IT IF TYPED ARITH PROC.
TLNN TBITS,BILTIN ;UNLESS BUILTIN PROC.
PUSHJ P,ALLSTO ;STORE THE REST.
DPUSHJ:
;; BY JRL 9-20-72 MAKE SURE PROCEDURE FORMALS CAN BE ACCESSED
GENMOV (ACCESS,0) ;MAKE SURE WE HAVE ACCESS
;; BY JRL
MOVE A,[PUSHJ RP,NOUSAC] ;PUSHJ PDP,ROUTINE.
TLNE FF,LPPROG ;A FOREACH IN PROGRESS AND
TLNN TBITS,MPBIND ;A MATCHING PROCEDURE?
PUSHJ P,EMITER
MVCAL: MOVOPS ;PROC SEMANTICS TO SECOND GROUP.
;BUG TRAP
SKIPN B,-1(P) ;SAVED FRTPRM POINTER.
ERR <DRYROT AT DPUSHJ>
QQQLRX: QTAKE (FTRPRM) ;POP OFF A GOODY
JRST LLQRLX
PUSH P,B
MOVE PNT,A
PUSHJ P,REMOP ;REMOP IT
POP P,B
JRST QQQLRX ;GET ALL OF THEM
LLQRLX:
MOVEI D,1 ;IF ARITH TYPE, RESULTS IN R1
JRST MRKCAL ;FINISH OUT, MARK RESULT
;;#HT# 6-14-72 DCS (1-2) SAVE ALL ACS, ALSO RF, WHEN FORTRAN SUBROUTINE
FTRCAL: TRNN TBITS2,ALTYPS≠(FORTRAN!PROCED);TYPED PROCEDURE?
JRST [PUSHJ P,ALLSTO
HRLI C,RF ;NO, STORE ALL ACS, SAVE F
EMIT (<PUSH RP,NOUSAC!USADDR!NORLC>)
JRST CALFTR]
;;RW#HT# (1-2)
MOVEI D,0 ;ASSURE R0 FREE
PUSHJ P,STORZ
MOVEI D,1 ;AND R1
PUSHJ P,STORZ
CALFTR: EMIT (<JSA 16,NOUSAC>) ;JSA 16,ROUTINE
MOVOPS ;SEMANTICS OF PROC TO 2D GROUP
; ***** BUG TRAP
SKIPN B,-1(P) ;FTRPRM POINTER
ERR <DRYROT -- FTRCAL> ;WASN'T A POINTER
ARGLUP: QTAKE (FTRPRM) ;GET NEXT ADCON DESCRIPTOR
JRST LLLQRX ; DONE WITH ADCONS
PUSH P,B ;SAVE UPDATED POINTER
JUMPL A,ARGFIX ;MOVEI,HRLI,MOVEM WAS DONE, FIX IT UP
PUSH P,A ;SAVE ADCON POINTER
HLRZ PNT,%TLINK(A) ;SEMANTICS OF AD BEING CONNED
HLLZ A,$ADR(A) ;TYPE BITS, ALREADY IN AC FIELD POS
PUSHJ P,GETAD ;GET DESCRIPTION
OR A,[JUMP NOUSAC]
PUSHJ P,EMITER ;JUMP TYP,ADDR
PUSHJ P,REMOP ;GET RID OF IT
POP P,A ;GET POINTER BACK
HRRZ LPSA,A ;→SEMANTICS OF ADCON
PUSHJ P,URGADR ;REMOVE FROM ADRTAB
FREBLK ;RETURN ADCON BLOCK TO FREE STORAGE
POP P,B ;UPDATED STACK PTR
JRST ARGLUP ;GET ALL OF THEM
ARGFIX: HRL B,A ;FIXUP
HRR B,PCNT ;ADDRESS
PUSHJ P,FBOUT ;OUTPUT FIXUP
EMIT (< JUMP NOADDR+NOUSAC>) ;ADDR ADDED LATER
POP P,B ;UPDATED QSTACK PTR
JRST ARGLUP ;RETURN
LLLQRX: MOVEI D,0 ;IF TYPED, RESULT IN 0
MRKCAL:
HLRZ TEMP,(P) ;NUMBER OF SDEPTH ADJUST WORDS
SUB TEMP,SDEPTH ;ADJUST
MOVNM TEMP,SDEPTH
HRRZ TEMP,(P) ;SIMILAR ADEPTH STUFF
SUB TEMP,ADEPTH
MOVNM TEMP,ADEPTH
POP P,TEMP ;TOSS OUT
POP P,FTRPRM ;RESTORE OLD QSTACK PTR
SETZM PNT
TLNE FF,LPPROG ;A FOREACH IN PROGRESS?
TLNN TBITS2,MPBIND ;THIS A MATCHING PROCEDURE CALL?
JRST ISTYPD ;NO
MOVE TEMP,%MPRO ;MESSAGE PROCEDURE TOKEN
MOVEM TEMP,PARRIG ;TELL THE PARSER
MOVE PNT,PNT2 ;TO BE REPLACED IN PARSE STACK
JRST MRKDN ;FINI
ISTYPD:
;;#HT# 6-14-72 DCS (2-2) RESTORE SAVED RF REGISTER
TRNE TBITS2,ALTYPS≠(FORTRAN!PROCED) ;TYPED PROC?
JRST TYPRC ;YES
TRNN TBITS2,FORTRAN ;NO, FORTRAN PROCEDURE?
JRST MRKDN ;NO, QUIT
HRLI C,RF ;YES, UNTYPED F4, RESTORE RF
EMIT (<POP RP,NOUSAC!USADDR!NORLC>)
JRST MRKDN
;;#HT# (2-2)
TYPRC: GENMOV (MARK,EXCHIN) ;TEMP INDICATES TYPE OF PROCEDURE
MOVEI TEMP,2 ;IF A STRING PROC, INCREASE
;;#HS# JRL 6-14-72 STRING ITEMVAR PROC. IS NOT A STRING PROC.
TRNE TBITS,ITMVAR!ITEM;STRING ITEMVAR PROC. NOT REALLY STRING
JRST MRKDN
;;#HS#
TRNE TBITS,STRING ; STRING STACK DEPTH
ADDM TEMP,SDEPTH
MRKDN: MOVEM PNT,GENRIG ;ONE OF THESE
MOVEM PNT,GENRIG+1 ;WILL COVER IT
POPJ P,
SUBTTL Return Statement
COMMENT ⊗RESULT -- Return (with or without value) from Procedure⊗
DSCR RESULTS, RESLT1
PRO RESULT RESLT1
DES
at RT0: SG ; → S ; EXEC RESLT1 ¬S9
EE2: RETURN ( @E ) → S EXEC RESULTS SCAN ¬S9
⊗
; SETUP PROCEDURE FOR BOTH KINDS OF RETURNS
RETSET: MOVE PNT2,TPROC ;CAN ONLY RETURN FROM INNERMOST PROC
PUSHJ P,GETAD2 ;SEMANTICS OF IT
TLNE TBITS2,MPBIND ;MATCHING PROCS ARE NO-NO'S
ERR <RETURN NOT VALID WITHIN MATCHING PROC.>,1
MOVSI TEMP,RTNDON ;MARK RETURN DONE THIS PROC
IORM TEMP,$SBITS(PNT2) ;IN SEMBLK
EXCH TEMP,(P) ;≥0 IN TOP OF STACK, RETN TO TEMP
JRST (TEMP) ;RETURN
↑RESLT1: PUSHJ P,RETSET ;GET SEMANTICS OF THIS PROC TO 2D GROUP
TRNE TBITS2,ALTYPS≠PROCED ;CANNOT BE TYPED
ERR <TYPED PROCEDURE MUST RETURN A VALUE>
JRST JMPOU1 ;GENERATE THE ARRAY RELEASES AND EXIT JUMP
↑RESULTS:PUSHJ P,RETSET
TRNN TBITS2,ALTYPS≠PROCED ;THIS MUST BE TYPED
ERR <UNTYPED PROCEDURE MUST NOT RETURN A VALUE>,1
;;#HQ#↓ 6-13-72 DCS ITEMVARS ARE ITEMVARS, NOT THEIR DATUMS!!!!!!!
TRNN TBITS2,ITEM!ITMVAR ;PRECLUDE DATUMS
TRNN TBITS2,STRING ;STRING VALUE RETURNED?
JRST ARRET ; NO, ARITHMETIC VALUE
STRRET: LEFT PNT2,%TLINK,LPSERR ; LPSA → 2D PROCEDURE BLOCK
HRRZ A,$NPRMS(LPSA) ;#PARAMS(STRING)
GETSEM (1) ;GET SEMANTICS OF RESULT
TLNN TBITS2,RECURS ;IF NOT RECURSIVE PROCEDURE
TLNE SBITS,STTEMP ; AND NOT A TEMP RESULT, THEN CAN
JRST RTSTR1 ; DO THE SUB HERE, ELSE JUST STACK
TRNE TBITS,STRING ;IF RESULT IS STRING VALUE FORMAL,
TLNN TBITS,VALUE ; AND IS FIRST STRING PARAM,
JRST NOTEZY ; CAN REPLACE SUB/PUSH BY DIFFERENT SUB
HRRZ TEMP,$NPRMS(LPSA) ;# STRING WORDS
SUBI TEMP,1 ;-1 TO MATCH HOPEFUL CANDIDATE
CAME TEMP,$ADR(PNT) ;THIS THE FIRST STRING PARAM?
JRST NOTEZY ; NO
SUBI A,2 ;REMOVE ONE FEWER STRINGS (LEAVE ANSWER)
PUSHJ P,MARKME ;NOW A TEMP STRING-TYPE RESULT
MOVEM PNT,GENLEF+1 ;WILL BE PICKED UP LATER
NOTEZY: JUMPE A,RTSET ;IF NOTHING TO SUBTRACT, DON'T DO IT
MOVN TEMP,A ;UPDATE SDEPTH TO REFLECT THE COMING SUB
ADDM TEMP,SDEPTH ; SO THAT REFERENCES TO PARAMS ARE RIGHT
HRLS A ; IN SUBSEQUENT STACKING OPERATION
PUSHJ P,CREINT ;FOR SUB
EMIT <SUB RSP,NOUSAC> ;SUB RSP,[XWD #,#]
PUSHJ P,REMOP ;REMOVE CONSTANT FROM USE
RTSET: SETOM (P) ;<0 IN TOP OF STACK, MARK THIS CASE
RTSTRG: GETSEM (1) ;SEMANTICS OF RESULT
RTSTR1: MOVEI B,STRING
GENMOV (STACK,INSIST) ;MAKE SURE RESULT IS STACKED
SETZM SDEPTH ;DON'T RECORD EFFECTS OF THIS PUSH
JRST JMPOU1 ;RETURN
ARRET: GETSEM (1) ;ARG.
MOVEI D,1 ;RESULTS TO AC 1
HRRZ B,TBITS2 ;TYPE CONVERSION IF NECESSARY
;; #JT# BY JRL 10-21-72 COPY SET TO BE RETURNED
LEP <
TRNN TBITS,ITMVAR
TRNN TBITS,SET
JRST ARRET2
PUSH P,PNT
GENMOV (STACK,INSIST)
MOVEI A,0
PUSHJ P,CREINT
GENMOV (STACK,GETD)
LPCALL (CATLST)
MOVNI A,2
ADDM A,ADEPTH
HRLI C,1
EMIT <POP RP,NOUSAC!USADDR!NORLC>
POP P,PNT
PUSHJ P,GETAD
JRST ARRET3
>;LEP
;; #JT#
ARRET2: GENMOV (GET,INSIST!SPAC!POSIT) ;LOAD THE AC
ARRET3: PUSHJ P,REMOP
JMPOUT: PUSHJ P,CLEARA ;FORGET ABOUT AC 1
JMPOU1: EXCHOP ;GET PROC SEMANTICS BACK FROM HIDING
RETJMP: PUSHJ P,GOSTO ;DUMP EVERYTHING, BUT REMEMBER WHERE
MOVE B,LEVEL ;CURRENT LEVEL
SUBI B,1 ;DO NOT ENCOUNTER PROCEDURE
PUSH P,PNT
PUSHJ P,TRAGO ;GUARANTEE ACCESS
POP P,PNT ;THE WORK IS DONE.
MOVE A,[JRST NOUSAC+USADDR] ;THE JUMP OUT
HRR C,PCNT ;PUT CURRENT IN CHAIN
POP P,TEMP ;IF <0, NON-REC, NON-TEMP STRING RESULT
JUMPL TEMP,OTHJMP ; JUMP PAST SUB/PUSH PAIR IN EXIT CODE
HRL C,$ACNO(PNT) ;THIS IS WHERE PROC. RET. FIXUP IS STORED.
HRRM C,$ACNO(PNT) ;CHAIN THE FIXUP.
JRST EMITER ;EMIT JUMP
OTHJMP: HLL C,$ADR(PNT) ;OTHER JUMP ADDR
HRLM C,$ADR(PNT) ;CHAIN
JRST EMITER ;DO IT
COMMENT ⊗DFVPV -- exec for default param values ⊗
ZERODATA();
PBITTS: 0 ;SAVE PARAM BITS HERE
ENDDATA
↑DFVPV0: MOVE A,BITS ;
MOVEM A,PBITTS ;SAVE THE BITS
POPJ P,
↑DFVPV: MOVE PNT,VARB ;THE MOST RECENT FORMAL ON VARB
DFV.01: PUSHJ P,GETAD ;RING
TLNE TBITS,FORMAL ;
JRST GOTVCT
HRRZ PNT,%RVARB(PNT) ;
JUMPN PNT,DFV.01 ;
ERR <DRYROT IN DFVPV, CAN CONTINUE>,1;
JRST DFV.2 ;
GOTVCT: TLNE TBITS,REFRNC ;
ERR <DEFAULT VALUES FOR REF PARAMS IS A VERY BAD IDEA>,1
MOVE PNT2,GENLEF+1 ;THE VALUE
HRRM PNT2,$VAL2(PNT) ;
DFV.2: MOVE A,PBITTS ;PUT BITS BACK
MOVEM A,BITS
POPJ P,
; CLNSET
↑CLNSET:
MOVE PNT,TTOP ;CURRENT BLOCK
HLRZ PNT2,%TLINK(PNT) ;SECOND SEMBLK
JUMPN PNT2,CLNS.1 ;HAVE ONE
GETBLK ;GET ONE
HRLM LPSA,%TLINK(PNT) ;SAVE IT
HRRZ PNT2,LPSA ;
CLNS.1: MOVE A,GENLEF+1 ;PROC SEMBLK
HLRZ B,%TLINK(A) ;SECOND BLOCK
MOVSI C,1 ;STACK DISPLS FOR 0 PARS
CAME C,$NPRMS(B) ;BETTER HAVE NO PARAMS
ERR <CANNOT USE A PROC WITH PARAMS FOR CLEANUP>,1
QPUSH (<$ACNO(PNT2)>) ;REMEMBER
MOVEI A,SET ;SO GO TO SOLVER WORKS
ORM A,$VAL(PNT) ;
POPJ P,
BEND PROCED